EMERGENCY Released DG*5.3*696 SEQ #634 Extracted from mail message **KIDS**:DG*5.3*696^ **INSTALL NAME** DG*5.3*696 "BLD",6571,0) DG*5.3*696^REGISTRATION^0^3060725^y "BLD",6571,1,0) ^^4^4^3060725^ "BLD",6571,1,1,0) This patch fixes a problem with the combat vet field used in screen 801 "BLD",6571,1,2,0) in the PTF Load/Edit option, fixes the transmission date on retransmitted "BLD",6571,1,3,0) transactions, permits closing a record when the patient has a single "BLD",6571,1,4,0) legal name, and refines the handling of the PTF census date file. "BLD",6571,4,0) ^9.64PA^^ "BLD",6571,6) 9^ "BLD",6571,"INI") DG696PRE "BLD",6571,"INIT") DG696PST "BLD",6571,"KRN",0) ^9.67PA^8989.52^19 "BLD",6571,"KRN",.4,0) .4 "BLD",6571,"KRN",.401,0) .401 "BLD",6571,"KRN",.402,0) .402 "BLD",6571,"KRN",.402,"NM",0) ^9.68A^1^1 "BLD",6571,"KRN",.402,"NM",1,0) DG801 FILE #46.1^46.1^0 "BLD",6571,"KRN",.402,"NM","B","DG801 FILE #46.1",1) "BLD",6571,"KRN",.403,0) .403 "BLD",6571,"KRN",.5,0) .5 "BLD",6571,"KRN",.84,0) .84 "BLD",6571,"KRN",3.6,0) 3.6 "BLD",6571,"KRN",3.8,0) 3.8 "BLD",6571,"KRN",9.2,0) 9.2 "BLD",6571,"KRN",9.8,0) 9.8 "BLD",6571,"KRN",9.8,"NM",0) ^9.68A^5^5 "BLD",6571,"KRN",9.8,"NM",1,0) DGPTFM^^0^B44706868 "BLD",6571,"KRN",9.8,"NM",2,0) DGPTFM3^^0^B16822857 "BLD",6571,"KRN",9.8,"NM",3,0) DGPTR1^^0^B25846829 "BLD",6571,"KRN",9.8,"NM",4,0) DGPT101^^0^B13245456 "BLD",6571,"KRN",9.8,"NM",5,0) DGPTCO1^^0^B25546385 "BLD",6571,"KRN",9.8,"NM","B","DGPT101",4) "BLD",6571,"KRN",9.8,"NM","B","DGPTCO1",5) "BLD",6571,"KRN",9.8,"NM","B","DGPTFM",1) "BLD",6571,"KRN",9.8,"NM","B","DGPTFM3",2) "BLD",6571,"KRN",9.8,"NM","B","DGPTR1",3) "BLD",6571,"KRN",19,0) 19 "BLD",6571,"KRN",19,"NM",0) ^9.68A^^ "BLD",6571,"KRN",19.1,0) 19.1 "BLD",6571,"KRN",101,0) 101 "BLD",6571,"KRN",409.61,0) 409.61 "BLD",6571,"KRN",771,0) 771 "BLD",6571,"KRN",870,0) 870 "BLD",6571,"KRN",8989.51,0) 8989.51 "BLD",6571,"KRN",8989.52,0) 8989.52 "BLD",6571,"KRN",8994,0) 8994 "BLD",6571,"KRN","B",.4,.4) "BLD",6571,"KRN","B",.401,.401) "BLD",6571,"KRN","B",.402,.402) "BLD",6571,"KRN","B",.403,.403) "BLD",6571,"KRN","B",.5,.5) "BLD",6571,"KRN","B",.84,.84) "BLD",6571,"KRN","B",3.6,3.6) "BLD",6571,"KRN","B",3.8,3.8) "BLD",6571,"KRN","B",9.2,9.2) "BLD",6571,"KRN","B",9.8,9.8) "BLD",6571,"KRN","B",19,19) "BLD",6571,"KRN","B",19.1,19.1) "BLD",6571,"KRN","B",101,101) "BLD",6571,"KRN","B",409.61,409.61) "BLD",6571,"KRN","B",771,771) "BLD",6571,"KRN","B",870,870) "BLD",6571,"KRN","B",8989.51,8989.51) "BLD",6571,"KRN","B",8989.52,8989.52) "BLD",6571,"KRN","B",8994,8994) "BLD",6571,"QUES",0) ^9.62^^ "BLD",6571,"REQB",0) ^9.611^4^3 "BLD",6571,"REQB",2,0) DG*5.3*678^1 "BLD",6571,"REQB",3,0) DG*5.3*683^1 "BLD",6571,"REQB",4,0) DG*5.3*432^1 "BLD",6571,"REQB","B","DG*5.3*432",4) "BLD",6571,"REQB","B","DG*5.3*678",2) "BLD",6571,"REQB","B","DG*5.3*683",3) "INI") DG696PRE "INIT") DG696PST "KRN",.402,2697,-1) 0^1 "KRN",.402,2697,0) DG801^3060119.1623^@^46.1^^@^3060119 "KRN",.402,2697,"DIAB",1,0,46.1,2) TREATED FOR AO CONDITION;"WAS TREATMENT RELATED TO AGENT ORANGE EXPOSURE?" "KRN",.402,2697,"DIAB",1,0,46.1,5) TREATMENT FOR HEAD/NECK CA;"WAS TREATMENT RELATED TO HEAD AND/OR NECK CANCER?" "KRN",.402,2697,"DIAB",2,0,46.1,1) COMBAT VET;"WAS TREATMENT RELATED TO COMBAT?" "KRN",.402,2697,"DIAB",2,0,46.1,4) TREATMENT FOR MST;"WAS TREATMENT RELATED TO MILITARY SEXUAL TRAUMA?" "KRN",.402,2697,"DIAB",3,0,46.1,0) TREATED FOR SC CONDITION;"WAS TREATMENT FOR A SERVICE CONNECTED CONDITION?" "KRN",.402,2697,"DIAB",4,0,46.1,3) EXPOSURE TO ENVIR CONTAMINANTS;"WAS TREATMENT RELATED TO ENVIRONMENTAL CONTAMINANT EXPOSURE?" "KRN",.402,2697,"DIAB",7,0,46.1,2) TREATMENT FOR IR CONDITION;"WAS TREATMENT RELATED TO IONIZING RADIATION EXPOSURE?" "KRN",.402,2697,"DR",1,46.1) I '$D(SDCLY(3)) S Y=$S($P($G(^DGICD9(46.1,D0,0)),U,2)="":"@11",1:"@10");D ELIG^DGPTUTL1;.02WAS TREATMENT FOR A SERVICE CONNECTED CONDITION?~;S Y="@11";@10;.02////0;@11; "KRN",.402,2697,"DR",1,46.1,1) I '$D(SDCLY(7)) S Y=$S($P($G(^DGICD9(46.1,D0,0)),U,8)="":"@21",1:"@20");.08WAS TREATMENT RELATED TO COMBAT?~;S Y="@21";@20;.08////0;@21;I '$D(SDCLY(1)) S Y=$S($P($G(^DGICD9(46.1,D0,0)),U,3)="":"@31",1:"@30"); "KRN",.402,2697,"DR",1,46.1,2) .03WAS TREATMENT RELATED TO AGENT ORANGE EXPOSURE?~;S Y="@31";@30;.03////0;@31;I '$D(SDCLY(2)) S Y=$S($P($G(^DGICD9(46.1,D0,0)),U,4)="":"@41",1:"@40");.04WAS TREATMENT RELATED TO IONIZING RADIATION EXPOSURE?~;S Y="@41";@40; "KRN",.402,2697,"DR",1,46.1,3) .04////0;@41;I '$D(SDCLY(4)) S Y=$S($P($G(^DGICD9(46.1,D0,0)),U,5)="":"@51",1:"@50");.05WAS TREATMENT RELATED TO ENVIRONMENTAL CONTAMINANT EXPOSURE?~;S Y="@51";@50;.05////0;@51; "KRN",.402,2697,"DR",1,46.1,4) I '$D(SDCLY(5)) S Y=$S($P($G(^DGICD9(46.1,D0,0)),U,6)="":"@61",1:"@60");.06WAS TREATMENT RELATED TO MILITARY SEXUAL TRAUMA?~;S Y="@61";@60;.06////0;@61;I '$D(SDCLY(6)) S Y=$S($P($G(^DGICD9(46.1,D0,0)),U,7)="":"@71",1:"@70"); "KRN",.402,2697,"DR",1,46.1,5) .07WAS TREATMENT RELATED TO HEAD AND/OR NECK CANCER?~;S Y="@71";@70;.07////0;@71;@99;1////^S X=PTF; "KRN",.402,2697,"ROU") ^DGPTX8 "KRN",.402,2697,"ROUOLD") DGPTX8 "MBREQ") 0 "ORD",7,.402) .402;7;;;EDEOUT^DIFROMSO(.402,DA,"",XPDA);FPRE^DIFROMSI(.402,"",XPDA);EPRE^DIFROMSI(.402,DA,$E("N",$G(XPDNEW)),XPDA,"",OLDA);;EPOST^DIFROMSI(.402,DA,"",XPDA);DEL^DIFROMSK(.402,"",%) "ORD",7,.402,0) INPUT TEMPLATE "PKG",5,-1) 1^1 "PKG",5,0) REGISTRATION^DG^PATIENT REGISTRATION, ADMISSION, DISCHARGE, EMBOSSER "PKG",5,20,0) ^9.402P^^ "PKG",5,22,0) ^9.49I^1^1 "PKG",5,22,1,0) 5.3^2930813 "PKG",5,22,1,"PAH",1,0) 696^3060725^100850 "PKG",5,22,1,"PAH",1,1,0) ^^4^4^3060725 "PKG",5,22,1,"PAH",1,1,1,0) This patch fixes a problem with the combat vet field used in screen 801 "PKG",5,22,1,"PAH",1,1,2,0) in the PTF Load/Edit option, fixes the transmission date on retransmitted "PKG",5,22,1,"PAH",1,1,3,0) transactions, permits closing a record when the patient has a single "PKG",5,22,1,"PAH",1,1,4,0) legal name, and refines the handling of the PTF census date file. "QUES","XPF1",0) Y "QUES","XPF1","??") ^D REP^XPDH "QUES","XPF1","A") Shall I write over your |FLAG| File "QUES","XPF1","B") YES "QUES","XPF1","M") D XPF1^XPDIQ "QUES","XPF2",0) Y "QUES","XPF2","??") ^D DTA^XPDH "QUES","XPF2","A") Want my data |FLAG| yours "QUES","XPF2","B") YES "QUES","XPF2","M") D XPF2^XPDIQ "QUES","XPI1",0) YO "QUES","XPI1","??") ^D INHIBIT^XPDH "QUES","XPI1","A") Want KIDS to INHIBIT LOGONs during the install "QUES","XPI1","B") YES "QUES","XPI1","M") D XPI1^XPDIQ "QUES","XPM1",0) PO^VA(200,:EM "QUES","XPM1","??") ^D MG^XPDH "QUES","XPM1","A") Enter the Coordinator for Mail Group '|FLAG|' "QUES","XPM1","B") "QUES","XPM1","M") D XPM1^XPDIQ "QUES","XPO1",0) Y "QUES","XPO1","??") ^D MENU^XPDH "QUES","XPO1","A") Want KIDS to Rebuild Menu Trees Upon Completion of Install "QUES","XPO1","B") YES "QUES","XPO1","M") D XPO1^XPDIQ "QUES","XPZ1",0) Y "QUES","XPZ1","??") ^D OPT^XPDH "QUES","XPZ1","A") Want to DISABLE Scheduled Options, Menu Options, and Protocols "QUES","XPZ1","B") YES "QUES","XPZ1","M") D XPZ1^XPDIQ "QUES","XPZ2",0) Y "QUES","XPZ2","??") ^D RTN^XPDH "QUES","XPZ2","A") Want to MOVE routines to other CPUs "QUES","XPZ2","B") NO "QUES","XPZ2","M") D XPZ2^XPDIQ "RTN") 7 "RTN","DG696PRE") 0^^B1987231^n/a "RTN","DG696PRE",1,0) DG696PRE ;BAY/JAT; "RTN","DG696PRE",2,0) ;;5.3;Registration;**696*;Aug 13,1993 "RTN","DG696PRE",3,0) ; "RTN","DG696PRE",4,0) ; This is a pre-init routine for DG*5.3*696 "RTN","DG696PRE",5,0) ; "RTN","DG696PRE",6,0) EN ; "RTN","DG696PRE",7,0) ; replace Y/N set with 1/0 "RTN","DG696PRE",8,0) D BMES^XPDUTL("Updating field #.08 of file #46.1") "RTN","DG696PRE",9,0) S ^DD(46.1,.08,0)="COMBAT VET^S^1:YES;0:NO;^0;8^Q" "RTN","DG696PRE",10,0) S ^DD(46.1,.08,"DT")=3060519 "RTN","DG696PRE",11,0) ; replace $N with $O "RTN","DG696PRE",12,0) D BMES^XPDUTL("Updating field #7.4 of file #45") "RTN","DG696PRE",13,0) S ^DD(45,7.4,0)="TRANSMISSION DATE^DCJ8,0X^^ ; ^S X=$S($D(^DGP(45.83,""C"",D0)):$O(^DGP(45.83,""C"",D0,0)),1:""""),X=$S($D(^DGP(45.83,+X,""P"",D0,0)):$P(^(0),U,2),1:"""")" "RTN","DG696PRE",14,0) S ^DD(45,7.4,"DT")=3060519 "RTN","DG696PRE",15,0) S ^DD(45,7.4,9.1)="S X=$S($D(^DGP(45.83,""C"",D0)):$O(^DGP(45.83,""C"",D0,0)),1:""""),X=$S($D(^DGP(45.83,+X,""P"",D0,0)):$P(^(0),U,2),1:"""")" "RTN","DG696PRE",16,0) Q "RTN","DG696PST") 0^^B701411^n/a "RTN","DG696PST",1,0) DG696PST ;BAY/JAT;cleanup of combat vet field on file 46.1 "RTN","DG696PST",2,0) ;;5.3;Registration;**696*;Aug 13,1993 "RTN","DG696PST",3,0) ; "RTN","DG696PST",4,0) ; This is a post-init routine for DG*5.3*696 "RTN","DG696PST",5,0) ; The purpose is to rewrite each entry that has a value in "RTN","DG696PST",6,0) ; field .08 of file #46.1 by replacing "Y" with "1" and "N" with 0. "RTN","DG696PST",7,0) ; "RTN","DG696PST",8,0) EN ; "RTN","DG696PST",9,0) D BMES^XPDUTL("Updating file #46.1") "RTN","DG696PST",10,0) N DGIEN,DGSET,FDATA,DIERR "RTN","DG696PST",11,0) S DGIEN=0 "RTN","DG696PST",12,0) F S DGIEN=$O(^DGICD9(46.1,DGIEN)) Q:'DGIEN D "RTN","DG696PST",13,0) .Q:$P($G(^DGICD9(46.1,DGIEN,0)),U,8)="" "RTN","DG696PST",14,0) .S DGSET="" "RTN","DG696PST",15,0) .I $P(^DGICD9(46.1,DGIEN,0),U,8)="Y" S DGSET=1 "RTN","DG696PST",16,0) .I $P(^DGICD9(46.1,DGIEN,0),U,8)="N" S DGSET=0 "RTN","DG696PST",17,0) .S FDATA(46.1,DGIEN_",",.08)=DGSET "RTN","DG696PST",18,0) .D FILE^DIE("","FDATA","DIERR") "RTN","DG696PST",19,0) K FDATA,DIERR "RTN","DG696PST",20,0) Q "RTN","DGPT101") 0^4^B13245456^B13150561 "RTN","DGPT101",1,0) DGPT101 ;ALB/MTC - 101/701 Austin Edit Checks ; 12 NOV 92 "RTN","DGPT101",2,0) ;;5.3;Registration;**8,164,180,247,415,678,696**;Aug 13, 1993 "RTN","DGPT101",3,0) ; "RTN","DGPT101",4,0) EN ; "RTN","DGPT101",5,0) S (DGPTFEF,DGPTERC)=0 "RTN","DGPT101",6,0) 101 ;-- process 101+701 data "RTN","DGPT101",7,0) N ERROR "RTN","DGPT101",8,0) ; "RTN","DGPT101",9,0) PARSE ;Set up record string, Call routine to parse record "RTN","DGPT101",10,0) S DGPTSTR=^TMP("AEDIT",$J,NODE,SEQ) "RTN","DGPT101",11,0) D SET^DGPT101P "RTN","DGPT101",12,0) D NOW^%DTC S DGPTTY=(17+$E(X,1))_$E(X,2,3) "RTN","DGPT101",13,0) 701 ;PROCESS 701 "RTN","DGPT101",14,0) S DGPTAL7=$O(^TMP("AEDIT",$J,"N701",SEQ)) I DGPTAL7="" S DGPTFEF=1 Q "RTN","DGPT101",15,0) D SET^DGPT701 I DGPTFEF Q "RTN","DGPT101",16,0) SET ; Start error piece, flags "RTN","DGPT101",17,0) S DGPTEDFL=0,DGPTSTR=^TMP("AEDIT",$J,NODE,SEQ) "RTN","DGPT101",18,0) SSN ; Start edits "RTN","DGPT101",19,0) I DGPTSSN'?9N!((DGPTPS=" ")&("9"[$E(DGPTSSN))) S DGPTERC=102 D ERR G:DGPTEDFL EXIT "RTN","DGPT101",20,0) I " P"'[DGPTPS S DGPTERC=101 D ERR G:DGPTEDFL EXIT "RTN","DGPT101",21,0) S DGPTPS=$S(DGPTPS="P":DGPTPS,1:"A") "RTN","DGPT101",22,0) PSEU ; "RTN","DGPT101",23,0) I DGPTPS="P" S DGPTERC=0 D PSE^DGPTAE01 I DGPTERC D ERR G:DGPTEDFL EXIT "RTN","DGPT101",24,0) DTE ; "RTN","DGPT101",25,0) S X=DGPTDTS,%DT="XT" D ^%DT I Y<0 S DGPTERC=103 D ERR G:DGPTEDFL EXIT "RTN","DGPT101",26,0) I Y>0 D DD^%DT S DGPTADT=$E(Y,5,6)_"-"_$E(Y,1,3)_"-"_$E(Y,9,12)_" "_$S($P(Y,"@",2)]"":$E($P(Y,"@",2),1,5),1:"00:00") "RTN","DGPT101",27,0) S X1=DGPTNOW,X2=$$FMDT($E(DGPTSTR,15,20)) D ^%DTC I X<0 S DGPTERC=140 D ERR G:DGPTEDFL EXIT "RTN","DGPT101",28,0) S DGPTDTS=$$FMDT($E(DGPTSTR,15,20))_"."_$E(DGPTSTR,21,24) "RTN","DGPT101",29,0) LN ; "RTN","DGPT101",30,0) I DGPTLN'?1.U." " S DGPTERC=105 D ERR G:DGPTEDFL EXIT "RTN","DGPT101",31,0) I DGPTFI'?.U&(DGPTFI'=" ")!((DGPTMI'?1U)&(DGPTMI'=" ")) S DGPTERC=106 D ERR G:DGPTEDFL EXIT "RTN","DGPT101",32,0) SRA ;-- may need to add more edits later "RTN","DGPT101",33,0) D ^DGPT10S1 I DGPTERC D ERR G:DGPTEDFL EXIT "RTN","DGPT101",34,0) SRP ; "RTN","DGPT101",35,0) N I "RTN","DGPT101",36,0) S DGPTERC=0 "RTN","DGPT101",37,0) I " 1234"'[DGPTSRP S DGPTERC=109 D ERR G:DGPTEDFL EXIT G POW "RTN","DGPT101",38,0) I "1234"[DGPTSRP S DGPTERC=109 F I=20:1:26 I DGPTSTTY[U_I_U S DGPTERC=0 Q "RTN","DGPT101",39,0) I DGPTERC D ERR G:DGPTEDFL EXIT "RTN","DGPT101",40,0) POW ; "RTN","DGPT101",41,0) I $L(DGPTPOW)'=1!("123456789AB "'[DGPTPOW) S DGPTERC=110 D ERR G:DGPTEDFL EXIT "RTN","DGPT101",42,0) MAR ; "RTN","DGPT101",43,0) I "MWDUSN"'[DGPTMRS S DGPTERC=111 D ERR G:DGPTEDFL EXIT "RTN","DGPT101",44,0) GEN ; "RTN","DGPT101",45,0) I "FM"'[DGPTGEN S DGPTERC=112 D ERR G:DGPTEDFL EXIT "RTN","DGPT101",46,0) S DGPTGEN1=$S(DGPTGEN="F":1,1:0) "RTN","DGPT101",47,0) DOB ; "RTN","DGPT101",48,0) S DGPTERC=0 D DB^DGPTAE01 I DGPTERC D ERR G:DGPTEDFL EXIT "RTN","DGPT101",49,0) POS ; "RTN","DGPT101",50,0) S DGPTERC=0 D ^DGPT10CB I DGPTERC D ERR G:DGPTEDFL EXIT "RTN","DGPT101",51,0) EXP ; "RTN","DGPT101",52,0) S DGPTERC=0 D AGO^DGPTAE01 I DGPTERC D ERR G:DGPTEDFL EXIT "RTN","DGPT101",53,0) S DGPTERC=0 D IRAD^DGPTAE01 I DGPTERC D ERR G:DGPTEDFL EXIT "RTN","DGPT101",54,0) HOME ; "RTN","DGPT101",55,0) S DGPTERC=0 D STATE^DGPTAE01 I DGPTERC D ERR G:DGPTEDFL EXIT "RTN","DGPT101",56,0) S DGPTERC=0 D CNTY^DGPTAE01 I DGPTERC D ERR G:DGPTEDFL EXIT "RTN","DGPT101",57,0) S DGPTERC=0 D ZIP^DGPTAE01 I DGPTERC D ERR G:DGPTEDFL EXIT "RTN","DGPT101",58,0) MT ; "RTN","DGPT101",59,0) S DGPTERC=0 D MT^DGPTAE01 I DGPTERC D ERR G:DGPTEDFL EXIT "RTN","DGPT101",60,0) ERI ; "RTN","DGPT101",61,0) S DGPTERC=0 I ("^K^"'[(U_DGPTERI_U))&(DGPTERI'=" ") S DGPTERC=125 D ERR G:DGPTEDFL EXIT "RTN","DGPT101",62,0) INCOM ; "RTN","DGPT101",63,0) I DGPTDDS<2911001 G GOOD "RTN","DGPT101",64,0) S DGPTERC=0 D INC^DGPTAE01 I DGPTERC D ERR G:DGPTEDFL EXIT "RTN","DGPT101",65,0) GOOD ; "RTN","DGPT101",66,0) W:'$D(ERROR) "." "RTN","DGPT101",67,0) ; "RTN","DGPT101",68,0) EXIT ; "RTN","DGPT101",69,0) K DGPTREC,DGPTORBD,DGPTLN,DGPTFI,DGPTMI,DGPTMRS,DGPTSTE,DGPTCTY,DGPTZIP,DGPTINC "RTN","DGPT101",70,0) K DGPTSRA,DGPTTF,DGPTSRP,DGPTPOS1,DGPTEXA,DGPTEXI,DGPTMTC,DGPTDTD,DGPTDSP,DGPTDTY,DGPTDOP,DGPTDVA,DGPTDPD,DGPTDRF,DGPTDAS,DGPTDCP,DGPTDDXE,DGPTDDXO,DGPTDLR,DGPTDLC,DGPTDSC,DGPTDAGE,DGPTDRG,DGPTSTR "RTN","DGPT101",71,0) K DGPT70LG,DGPT70SU,DGPT70DR,DGPT70X4,DGPTDXV1,DGPTDXV2 "RTN","DGPT101",72,0) Q "RTN","DGPT101",73,0) ERR ; "RTN","DGPT101",74,0) D WRTERR^DGPTAE(DGPTERC,NODE,SEQ) "RTN","DGPT101",75,0) S ERROR=1 "RTN","DGPT101",76,0) Q "RTN","DGPT101",77,0) FMDT(X) ; change to fm date for y2k "RTN","DGPT101",78,0) N Y "RTN","DGPT101",79,0) D ^%DT "RTN","DGPT101",80,0) Q Y "RTN","DGPTCO1") 0^5^B25546385^B23976970 "RTN","DGPTCO1",1,0) DGPTCO1 ;ALB/MJK - Census Status Report ; 5/2/05 2:41pm "RTN","DGPTCO1",2,0) ;;5.3;Registration;**136,383,432,696**;Aug 13, 1993 "RTN","DGPTCO1",3,0) ; "RTN","DGPTCO1",4,0) EN D CHKCUR W ! D DATE "RTN","DGPTCO1",5,0) S DIC("A")="Generate PTF Census Status Report for Census date: ",DIC="^DG(45.86,",DIC(0)="AEMQ" S:Y]"" DIC("B")=Y "RTN","DGPTCO1",6,0) D ^DIC K DIC G ENQ:Y<0 "RTN","DGPTCO1",7,0) S DGCN=+Y,DGCDT=+$P(Y,U,2)_".9" K DGCHOICE "RTN","DGPTCO1",8,0) D DIV^DGPTCO2 G ENQ:'$D(DGCHOICE("DIV")) "RTN","DGPTCO1",9,0) D STATUS^DGPTCO2 G ENQ:'$D(DGCHOICE("STATUS")) "RTN","DGPTCO1",10,0) S %ZIS="NQ" D ^%ZIS K %ZIS G ENQ:POP D DOQ G ENQ:POP S DGIOP=ION_";"_IOM_";"_IOSL "RTN","DGPTCO1",11,0) I 'DGQ D START G ENQ "RTN","DGPTCO1",12,0) S ZTRTN="START^DGPTCO1",ZTIO=DGIOP,ZTDESC="Census Status Report" "RTN","DGPTCO1",13,0) F X="DGCHOICE(","DGCDT","DGCN","DGIOP" S ZTSAVE(X)="" "RTN","DGPTCO1",14,0) D ^%ZTLOAD D ^%ZISC "RTN","DGPTCO1",15,0) ENQ K DGQ,DHIT,DIOEND,DGC,DGCN,DGCDT,DGIOP,DGCHOICE,DIS "RTN","DGPTCO1",16,0) Q "RTN","DGPTCO1",17,0) ; "RTN","DGPTCO1",18,0) START ; -- produce report "RTN","DGPTCO1",19,0) ;Lock global to prevent duplicate entries in Census Workfile "RTN","DGPTCO1",20,0) L +^DG(45.85,"DGPT CENSUS REGEN WORKFILE"):5 I '$T D Q "RTN","DGPTCO1",21,0) .N DGPTMSG "RTN","DGPTCO1",22,0) .D BLDMSG^DGPTCR "RTN","DGPTCO1",23,0) .I $E(IOST,1,2)'="C-" D SNDMSG^DGPTCR,ENQ Q "RTN","DGPTCO1",24,0) .N DGPTLINE "RTN","DGPTCO1",25,0) .S DGPTLINE=0 "RTN","DGPTCO1",26,0) .F S DGPTLINE=$O(DGPTMSG(DGPTLINE)) Q:'DGPTLINE W !,?5,DGPTMSG(DGPTLINE,0) "RTN","DGPTCO1",27,0) .Q "RTN","DGPTCO1",28,0) I '$D(^DG(45.85,"ACENSUS",DGCN)) D REGEN^DGPTCR "RTN","DGPTCO1",29,0) S DIC="^DG(45.85,",(BY,FLDS)="[DGPT WORKFILE]",L=0,FR=DGCN_",,@",TO=DGCN_",," "RTN","DGPTCO1",30,0) I DGCHOICE("STATUS")'="All" S (FR,TO)=DGCN_",,"_DGCHOICE("STATUS") "RTN","DGPTCO1",31,0) S DIS(0)="D DIS^DGPTCO1",DHIT="D DHIT^DGPTCO1",DIOEND="D DIOEND^DGPTCO1" "RTN","DGPTCO1",32,0) S Y=$P(DGCDT,".") X ^DD("DD") S DHD="Census Status Report for "_Y "RTN","DGPTCO1",33,0) S IOP=DGIOP K DGC "RTN","DGPTCO1",34,0) D EN1^DIP,ENQ "RTN","DGPTCO1",35,0) L -^DG(45.85,"DGPT CENSUS REGEN WORKFILE") "RTN","DGPTCO1",36,0) END Q "RTN","DGPTCO1",37,0) ; "RTN","DGPTCO1",38,0) DIOEND ; -- logic called at end of rpt for totals "RTN","DGPTCO1",39,0) I $E(IOST)="C" S DIR(0)="E" D ^DIR K DIR G DIOENDQ:X="^" "RTN","DGPTCO1",40,0) N D,S,Z S D="",Z="zzzz",$P(DGLN,"-",81)="" D NOW^%DTC S Y=% X ^DD("DD") "RTN","DGPTCO1",41,0) W @IOF,?30,"Census Status Report",?59,Y,!!?26,"Division Summary Statistics",! "RTN","DGPTCO1",42,0) ; "RTN","DGPTCO1",43,0) F I=0:0 S D=$O(DGC(D)) Q:D="" D DIV S S="" F J=0:0 S S=$O(DGC(D,S)) Q:S="" S C=DGC(D,S) D PRT I $O(DGC(D,S))=Z D TOT Q "RTN","DGPTCO1",44,0) W !,DGLN,! "RTN","DGPTCO1",45,0) I $E(IOST)="C" S DIR(0)="E" D ^DIR K DIR "RTN","DGPTCO1",46,0) DIOENDQ K C,DGLN Q "RTN","DGPTCO1",47,0) ; "RTN","DGPTCO1",48,0) DIV ; "RTN","DGPTCO1",49,0) W !,DGLN "RTN","DGPTCO1",50,0) I D="TOT" W !!?5,"OVERALL STATISTICS:" Q "RTN","DGPTCO1",51,0) W:$D(^DG(40.8,+D,0)) !?5,$P(^(0),U),":" "RTN","DGPTCO1",52,0) Q "RTN","DGPTCO1",53,0) ; "RTN","DGPTCO1",54,0) TOT ; "RTN","DGPTCO1",55,0) W !?10,$S(D="TOT":"Grand Total: ",1:"Division Total: "),?30,$J(DGC(D,Z),4) "RTN","DGPTCO1",56,0) Q "RTN","DGPTCO1",57,0) ; "RTN","DGPTCO1",58,0) PRT ; "RTN","DGPTCO1",59,0) W !?10,S,": ",?30,$J(C,4) "RTN","DGPTCO1",60,0) S:D'="TOT" DGC("TOT",S)=$S($D(DGC("TOT",S)):DGC("TOT",S),1:0)+C,DGC("TOT",Z)=$S($D(DGC("TOT",Z)):DGC("TOT",Z),1:0)+C "RTN","DGPTCO1",61,0) Q "RTN","DGPTCO1",62,0) ; "RTN","DGPTCO1",63,0) DIS ; -- $T logic for each entry "RTN","DGPTCO1",64,0) N X S X=^DG(45.85,D0,0) "RTN","DGPTCO1",65,0) I DGCHOICE("DIV")=1 G DISQ "RTN","DGPTCO1",66,0) I $D(DGCHOICE("DIV",$S($D(^DIC(42,+$P(X,U,6),0)):+$P(^(0),U,11),1:0))) "RTN","DGPTCO1",67,0) DISQ Q "RTN","DGPTCO1",68,0) ; "RTN","DGPTCO1",69,0) DHIT ; -- logic called for each entry printed cum stats; DGC(div,status) "RTN","DGPTCO1",70,0) N D,S,Z S Z="zzzz" D STATUS "RTN","DGPTCO1",71,0) S S=X,D=$S($D(^DIC(42,+$P(^DG(45.85,D0,0),U,6),0)):+$P(^(0),U,11),1:0) "RTN","DGPTCO1",72,0) S DGC(D,S)=$S($D(DGC(D,S)):DGC(D,S),1:0)+1,DGC(D,Z)=$S($D(DGC(D,Z)):DGC(D,Z),1:0)+1 "RTN","DGPTCO1",73,0) Q "RTN","DGPTCO1",74,0) ; "RTN","DGPTCO1",75,0) FIND ; -- find CENSUS rec# "RTN","DGPTCO1",76,0) ; input: D0 := ifn of 45.85 "RTN","DGPTCO1",77,0) ; output: X := status ; DGCI := census ifn ; PTF := ptf ifn "RTN","DGPTCO1",78,0) ; "RTN","DGPTCO1",79,0) S DGCI="",X=0,Y=$S($D(^DG(45.85,D0,0)):^(0),1:"") "RTN","DGPTCO1",80,0) G FINDQ:'Y S PTF=+$P(Y,U,12) "RTN","DGPTCO1",81,0) F DGCI=0:0 S DGCI=$O(^DGPT("ACENSUS",PTF,DGCI)) Q:'DGCI I $D(^DGPT(DGCI,0)),$P(^(0),U,13)=+$P(Y,U,4) S X=+$P(^(0),U,6) Q "RTN","DGPTCO1",82,0) FINDQ Q "RTN","DGPTCO1",83,0) ; "RTN","DGPTCO1",84,0) STATUS ; -- compute CENSUS status "RTN","DGPTCO1",85,0) D FIND S X=$P($P($P(^DD(45,6,0),U,3),X_":",2),";") "RTN","DGPTCO1",86,0) K DGCI,PTF,Y Q "RTN","DGPTCO1",87,0) ; "RTN","DGPTCO1",88,0) CREC ; -- compute CENSUS rec# "RTN","DGPTCO1",89,0) D FIND S X=DGCI "RTN","DGPTCO1",90,0) K DGCI,PTF,Y Q "RTN","DGPTCO1",91,0) ; "RTN","DGPTCO1",92,0) DATE ; -- calculate default census date "RTN","DGPTCO1",93,0) S Y=$S($D(^DG(45.86,+$O(^DG(45.86,"AC",1,0)),0)):+^(0),1:"") "RTN","DGPTCO1",94,0) X:Y]"" ^DD("DD") "RTN","DGPTCO1",95,0) Q "RTN","DGPTCO1",96,0) DOQ ;-- check if output device is queued. if not ask "RTN","DGPTCO1",97,0) S DGQ=0 "RTN","DGPTCO1",98,0) I $D(IO("Q")) S DGQ=1 G DOQT "RTN","DGPTCO1",99,0) I IO=IO(0) G DOQT "RTN","DGPTCO1",100,0) S DIR(0)="Y",DIR("A")="DO YOU WANT YOUR OUTPUT QUEUED",DIR("B")="YES" "RTN","DGPTCO1",101,0) D ^DIR "RTN","DGPTCO1",102,0) I Y S DGQ=1 "RTN","DGPTCO1",103,0) DOQT ; "RTN","DGPTCO1",104,0) K Y,DIR "RTN","DGPTCO1",105,0) Q "RTN","DGPTCO1",106,0) CHKCUR ; -- checks if new PTF Census Date record is needed "RTN","DGPTCO1",107,0) N DGIEN,DGCLOSE,DGACT,ERR "RTN","DGPTCO1",108,0) S DGIEN=$S($D(^DG(45.86,+$O(^DG(45.86,"AC",1,0)),0)):+^(0),1:"") "RTN","DGPTCO1",109,0) S DGIEN=$O(^DG(45.86,"B",+$G(DGIEN),0)) "RTN","DGPTCO1",110,0) S ERR=0 "RTN","DGPTCO1",111,0) I 'DGIEN S ERR=1 D ERR Q "RTN","DGPTCO1",112,0) ; look at last census closeout date "RTN","DGPTCO1",113,0) S DGCLOSE=$P($G(^DG(45.86,DGIEN,0)),U,2) "RTN","DGPTCO1",114,0) I 'DGCLOSE S ERR=1 D ERR Q "RTN","DGPTCO1",115,0) I $E(DGCLOSE,6,7)'=19 S ERR=1 "RTN","DGPTCO1",116,0) S DGACT=$P($G(^DG(45.86,DGIEN,0)),U,4) "RTN","DGPTCO1",117,0) I 'DGACT S ERR=1 "RTN","DGPTCO1",118,0) I ERR D ERR Q "RTN","DGPTCO1",119,0) I DT>DGCLOSE D ADDREC "RTN","DGPTCO1",120,0) Q "RTN","DGPTCO1",121,0) ADDREC ; -- add new record "RTN","DGPTCO1",122,0) N DA,DIE,DR,DGYR,DGMONTH,DGSTRT,DGENDT,ERR,FDA,IEN696,ERR696 "RTN","DGPTCO1",123,0) ; first inactivate last record "RTN","DGPTCO1",124,0) S DA=DGIEN,DIE="^DG(45.86,",DR=".04////0" D ^DIE "RTN","DGPTCO1",125,0) S DGYR=$E(DGCLOSE,1,3) "RTN","DGPTCO1",126,0) ; create new record depending on last closeout date (month) "RTN","DGPTCO1",127,0) S DGMONTH=$E(DGCLOSE,4,5) "RTN","DGPTCO1",128,0) I DGMONTH>"00",DGMONTH<"04" S DGSTRT=DGYR_"0101",DGENDT=DGYR_"0331",DGCLOSE=DGYR_"0419" "RTN","DGPTCO1",129,0) I DGMONTH>"03",DGMONTH<"07" S DGSTRT=DGYR_"0401",DGENDT=DGYR_"0630",DGCLOSE=DGYR_"0719" "RTN","DGPTCO1",130,0) I DGMONTH>"06",DGMONTH<"10" S DGSTRT=DGYR_"0701",DGENDT=DGYR_"0930",DGCLOSE=DGYR_"1019" "RTN","DGPTCO1",131,0) I DGMONTH>"09",DGMONTH<"13" S DGSTRT=DGYR_"1001",DGENDT=DGYR_"1231",DGYR=DGYR+1,DGCLOSE=DGYR_"0119" "RTN","DGPTCO1",132,0) ;S DIC="^DG(45.86,",X=DGENDT,DIC(0)="" K DO D FILE^DICN K DIC "RTN","DGPTCO1",133,0) ;I Y'>0 S ERR=1 D ERR Q "RTN","DGPTCO1",134,0) ;S DIE="^DG(45.86,",DA=+Y,DR=".02////"_DGCLOSE_";.03////2970331;.04////1;.05////"_DGSTRT "RTN","DGPTCO1",135,0) ;D ^DIE K DIE,DR,DA "RTN","DGPTCO1",136,0) S FDA(696,45.86,"?+1,",.01)=DGENDT "RTN","DGPTCO1",137,0) S FDA(696,45.86,"?+1,",.02)=DGCLOSE "RTN","DGPTCO1",138,0) S FDA(696,45.86,"?+1,",.03)=2970331 "RTN","DGPTCO1",139,0) S FDA(696,45.86,"?+1,",.04)=1 "RTN","DGPTCO1",140,0) S FDA(696,45.86,"?+1,",.05)=DGSTRT "RTN","DGPTCO1",141,0) D UPDATE^DIE("","FDA(696)","IEN696","ERR696") "RTN","DGPTCO1",142,0) I $D(ERR696) S ERR=1 D ERR "RTN","DGPTCO1",143,0) Q "RTN","DGPTCO1",144,0) ERR ; "RTN","DGPTCO1",145,0) D BMES^XPDUTL("Problem with PTF CENSUS DATE File (#45.86).") "RTN","DGPTCO1",146,0) D BMES^XPDUTL("Please notify your Supervisor !!.") "RTN","DGPTCO1",147,0) Q "RTN","DGPTCO1",148,0) ; "RTN","DGPTFM") 0^1^B44706868^B44316891 "RTN","DGPTFM",1,0) DGPTFM ;ALB/MTC - PTF OP-PRO-DIAG ;7/22/05 9:18am "RTN","DGPTFM",2,0) ;;5.3;Registration;**510,517,590,594,606,635,683,696**;Aug 13, 1993 "RTN","DGPTFM",3,0) K M,S,M1,M2,M3,S1,S2,PS2,SDCLY,^TMP("PTF",$J) "RTN","DGPTFM",4,0) GET S I=0 F I1=1:1 S I=$O(^DGPT(PTF,"M",I)) Q:'I S (M3(I1),M(I1))=^(I,0) I $D(^DGPT(PTF,"M",I,"P")) S $P(M(I1),U,20)=^("P") "RTN","DGPTFM",5,0) K MT D ORDER^DGPTF K MT D GETVAR^DGPTFM6,CL^SDCO21(DFN,$P(^DGPT(PTF,0),U,2),"",.SDCLY),MOB^DGPTFM2 "RTN","DGPTFM",6,0) S DGPC=I1-1 D WR K M1,M2,^UTILITY($J) S ST=1,M2=0 "RTN","DGPTFM",7,0) DIAG K DGZSER,DGZPRO,DGZSUR S DGZDIAG=1 F J=ST:2:PM S NL=1,L5=0,L6=J D WD2 S L5=1,L6=J+1 D:$D(M(L6)) WD2 D WD G PRO1:$Y>16 D WD3^DGPTFM8 G PRO1:$Y>16 W ! "RTN","DGPTFM",8,0) S ST=1 G SER "RTN","DGPTFM",9,0) WD F J1=1:1:11 I J1'=6 S L=$P(M(J),U,J1+4),L1=0,L3=1 D:+L WD1 S L1=1,L=$S($D(M(J+1)):$P(M(J+1),U,J1+4),1:"") D:+L WD1 "RTN","DGPTFM",10,0) Q "RTN","DGPTFM",11,0) WD1 S N=$$ICDDX^ICDCODE(+L,$$GETDATE^ICDGTDRG(PTF)),L2=$S(N:$P(N,U,2,99),1:""),M2=M2+1,L4=$P(L2,"^",1),L4=L4_$E(" ",1,3-$L($P(L4,".",2))) "RTN","DGPTFM",12,0) W:L3 ! S:L3 L3=0 W ?L1*40,$J(M2,3)," ",$J(L4,7)," ",$E($P(L2,U,3),1,25) K ^UTILITY($J,"M2",M2) S ^UTILITY($J,"M2",M2)=+M(J+L1)_U_J1 Q "RTN","DGPTFM",13,0) WD2 N Z3 "RTN","DGPTFM",14,0) X:NL "W ! S NL=0" W ?L5*40,"Move #",+L6 S Z=M(L6),Z3=M3(L6) W:+Z=1 " D/C" S Y=$P(Z,U,10)\1 D D^DGPTUTL W " ",Y," " "RTN","DGPTFM",15,0) W " <",$S($P(Z3,U,18)=1:"",1:"N"),"SC"_$S($P(Z3,U,26)="Y":",AO",1:"")_$S($P(Z3,U,27)="Y":",IR",1:"")_$S($P(Z3,U,28)="Y":",EC",1:"")_">" "RTN","DGPTFM",16,0) I $D(^DIC(42.4,+$P(Z,U,2),0)) D "RTN","DGPTFM",17,0) . I $P(^DIC(42.4,+$P(Z,U,2),0),U,2)'="" W $E($P(^DIC(42.4,+$P(Z,U,2),0),U,2),1,10) "RTN","DGPTFM",18,0) . E W $E($P(^(0),U,1),1,10) "RTN","DGPTFM",19,0) Q "RTN","DGPTFM",20,0) NDG D WR S I=0 K M,M1,M2 S M2=0 F I1=1:1 S I=$O(^DGPT(PTF,"M",I)) Q:I'>0 S M(I1)=^(I,0) "RTN","DGPTFM",21,0) S PM=I1-1 D ORDER^DGPTF K MT G DIAG:$D(ST) G GET S ST=1 "RTN","DGPTFM",22,0) SER K DGZDIAG,DGZPRO,DGZSUR S DGZSER=1 G PRO1:$Y>19 K S1,S2 S S2=0 G SERV:ST G PRO "RTN","DGPTFM",23,0) SERV F J=ST:2:SU S NL=1,L5=0,L6=J D SD2 S L5=1,L6=J+1 D:$D(S(L6)) SD2 D SD G PRO1:$Y>11 D SD3^DGPTFM8 G PRO1:$Y>11 W ! "RTN","DGPTFM",24,0) G PRC^DGPTFM0 "RTN","DGPTFM",25,0) SD F J1=1:1:5 S L=$P(S(J),U,J1+7),L1=0,L3=1 D:+L SD1 S L1=1,L=$S($D(S(J+1)):$P(S(J+1),U,J1+7),1:"") D:+L SD1 "RTN","DGPTFM",26,0) Q "RTN","DGPTFM",27,0) SD1 S N=$$ICDOP^ICDCODE(+L,$$GETDATE^ICDGTDRG(PTF)),L2=$S(N:$P(N,U,2,99),1:""),S2=S2+1,L4=$P(L2,"^",1),L4=L4_$E(" ",1,3-$L($P(L4,".",2))) "RTN","DGPTFM",28,0) W:L3 ! S:L3 L3=0 W ?L1*40,$J(S2,3)," ",$J(L4,7)," ",$E($P(L2,U,4),1,25) K S2(S2) S S2(S2)=J+L1_U_J1 Q "RTN","DGPTFM",29,0) SD2 S Y=+S(L6) D D^DGPTUTL W:NL ! S:NL NL=0 W ?L5*40,L6,"-Surgery date: ",Y "RTN","DGPTFM",30,0) Q "RTN","DGPTFM",31,0) NSR K S,S1,S2 S I=0 F I1=1:1 S I=$O(^DGPT(PTF,"S",I)) Q:I'>0 S S(I1)=^(I,0),S(I1,1)=I "RTN","DGPTFM",32,0) S S2=0,SU=I1-1 D WR G SERV "RTN","DGPTFM",33,0) ; "RTN","DGPTFM",34,0) WR W @IOF,HEAD,?70 S Z="" D Z Q "RTN","DGPTFM",35,0) PRO K DGZSER,DGZDIAG,DGZSUR S DGZPRO=1 G PRO1:$Y>14 K P1,P2 S ST=1,P2=0 G NPR:'$D(PROC) "RTN","DGPTFM",36,0) PROC D:$Y>14 WR W:PROC]"" !!,"Procedures: ",! "RTN","DGPTFM",37,0) F J1=1:1:5 S L=$P(PROC,"^",J1) I L'="" S P2=P2+1,N=$$ICDOP^ICDCODE(+L,$$GETDATE^ICDGTDRG(PTF)),L2=$S(N:$P(N,U,2,99),1:""),L4=$P(L2,U,1),L4=L4_$E(" ",1,3-$L($P(L4,".",2))) D "RTN","DGPTFM",38,0) .W:$X>5 ?40 W $J(P2,3)," ",$J(L4,7)," ",$E($P(L2,"^",4),1,25) K P2(P2) S P2(P2)=J1 W:$X>45 ! "RTN","DGPTFM",39,0) K DGZSER,DGZPRO,DGZDIAG,DGZSUR "RTN","DGPTFM",40,0) ENC G PRO1:$Y>7,PRO1:'$P(DGZPRF,U,3) "RTN","DGPTFM",41,0) PF S PS2=0,J=+DGZPRF,Y=+DGZPRF(J),DGSTRT=$S(+$P(DGZPRF,U,4):$P(DGZPRF,U,4),1:4),DGLST=0 "RTN","DGPTFM",42,0) D CL^SDCO21(DFN,+DGZPRF(J),"",.SDCLY),ICDINFO^DGAPI(DFN,PTF),XREF^DGPTFM21 ; load SCI info and DGN's for this service date "RTN","DGPTFM",43,0) D D^DGPTUTL W !,J,"-CPT Capture Date/Time: ",Y W:($P(DGZPRF,U,2)-1!($G(PGBRK))) " (cont.)" "RTN","DGPTFM",44,0) I $P(DGZPRF(J),U,2) W !,?5,"Referring or Ordering Provider: " S L=$P(DGZPRF(J),U,2) D PRV "RTN","DGPTFM",45,0) W !,?5,"Rendering Provider: " S L=$P(DGZPRF(J),U,3) D PRV "RTN","DGPTFM",46,0) I $P(DGZPRF(J),U,5) W !,?5,"Rendering Location: ",$P($G(^SC($P(DGZPRF(J),U,5),0)),U) "RTN","DGPTFM",47,0) S (L1,PGBRK)=0 "RTN","DGPTFM",48,0) F K=$P(DGZPRF,U,2):1 Q:'$D(DGZPRF(J,K)) I '$G(DGZPRF(J,K,9)) S PS2=PS2+1 W !,?2,PS2," " D CPT^DGPTUTL1 D Q:$Y+$G(DGZPRF(J,K+1,1))>16!($G(PGBRK)) "RTN","DGPTFM",49,0) . W !,?4 S $P(DS,"-",27)="" W DS," Related Diagnosis ",DS "RTN","DGPTFM",50,0) . F L1=DGSTRT:1:11 S DGLOC=$S(L1<8:L1,1:L1+7),CD=$P(DGZPRF(J,K),U,DGLOC) I CD D I $Y+$G(CKSCI)>16 S PGBRK=1 Q "RTN","DGPTFM",51,0) . . S N=$$ICDDX^ICDCODE(CD,$$GETDATE^ICDGTDRG(PTF)),N=$S(N:$P(N,U,2,99),1:"") "RTN","DGPTFM",52,0) . . S CD=$P(N,U) W !,?8,CD," ",$P(N,U,3) "RTN","DGPTFM",53,0) . . D CKSCI($P(DGZPRF(J,K),U,DGLOC)) "RTN","DGPTFM",54,0) . S PS2(PS2)=J_U_K,CD=1,DGLOC=0,DGSTRT=4 "RTN","DGPTFM",55,0) I L1'=11,$S(L1<8:$P($G(DGZPRF(J,K)),U,L1+1,7),1:"")_$P($G(DGZPRF(J,K)),U,$S(L1<8:15,1:L1+8),18)?."^" S L1=11 "RTN","DGPTFM",56,0) I L1=11 S $P(DGZPRF,U,1,2)=$S($D(DGZPRF(J,K+1)):J_U_(K+1),1:J+1_U_1),$P(DGZPRF,U,4)="",PGBRK=0 "RTN","DGPTFM",57,0) E S $P(DGZPRF,U,1,2)=J_U_K,$P(DGZPRF,U,4)=L1+1 "RTN","DGPTFM",58,0) ;I '$D(DGZPRF(J,K+1)) S $P(DGZPRF,U,1,2)=$S($P($G(DGZPRF(J,K)),U,NXTDGN)'="":J,1:J+1)_U_1,$P(DGZPRF,U,4)=DGLST "RTN","DGPTFM",59,0) ;I $D(DGZPRF(J,K+1)) S $P(DGZPRF,U,1,2)=J_U_(K+1) "RTN","DGPTFM",60,0) K I,K,L,L1,CD,N G PRO1 "RTN","DGPTFM",61,0) ; "RTN","DGPTFM",62,0) CKSCI(IEN) ;print SCI for each Diagnosis code "RTN","DGPTFM",63,0) N DGINFO Q:'$D(XREF(IEN)) "RTN","DGPTFM",64,0) S DGINFO=$G(^DGICD9(46.1,(XREF(IEN)),0)),CKSCI=0 "RTN","DGPTFM",65,0) I 'DGINFO Q "RTN","DGPTFM",66,0) F I=3,7,1,2,4:1:6 I $D(SDCLY(I)) S L=$S(I=3:8,I<4:8+I,1:7+I) D "RTN","DGPTFM",67,0) .W ?45 S M=1,CKSCI=CKSCI+1 "RTN","DGPTFM",68,0) .W $P("Treated for AO Condition^Treated for IR Condition^Treated for SC Condition^Exposed to Envir Contaminants^Treatment for MST^Treatment for Head/Neck CA^Related to Combat",U,I) "RTN","DGPTFM",69,0) .;I I'=7 W ":",$S($P(DGINFO,U,($S(I<3:I+2,I=3:2,1:I+1))):"YES",1:"NO"),! "RTN","DGPTFM",70,0) .;I I=7 W ":",$S($P(DGINFO,U,8)="Y":"YES",1:"NO"),! "RTN","DGPTFM",71,0) .W ":",$S($P(DGINFO,U,8)="Y":"YES",1:"NO"),! "RTN","DGPTFM",72,0) Q ;CKSCI "RTN","DGPTFM",73,0) ; "RTN","DGPTFM",74,0) NPR S ST=1,PROC=$S($D(^DGPT(PTF,"401P")):^("401P"),1:"") D WR G PRO "RTN","DGPTFM",75,0) ; "RTN","DGPTFM",76,0) NPS D WR G PF "RTN","DGPTFM",77,0) ; "RTN","DGPTFM",78,0) DONE G EN1^DGPTF4 "RTN","DGPTFM",79,0) PRO1 ;SET MENU TYPE AND DISPLAY MENU "RTN","DGPTFM",80,0) N ICDVDT,ICPTVDT "RTN","DGPTFM",81,0) S (ICDVDT,ICPTVDT)=$S($D(PTF):$$GETDATE^ICDGTDRG(PTF),1:DT) "RTN","DGPTFM",82,0) S DGNUM=$S($D(DGZDIAG)!($D(DGZPRO))!($D(DGZSER))!($D(DGZSUR)!(+DGZPRF-1'=$P(DGZPRF,U,3))):"MAS",1:"701") G MAS^DGPTFJC:DGST F X=$Y:1:(IOSL-8) W ! "RTN","DGPTFM",83,0) W !! S Z="Patient Movements:" W Z S Z=" "_$S(DGPTFE:"M=Add PM X=Delete PM",1:"M=Edit Treat Spec/PM ")_" A=Add Code D=Delete Code V=Edit Mov" W Z "RTN","DGPTFM",84,0) W ! S Z="Surgical Episodes:" W Z S Z=" S=Add SE Z=Delete SE O=Add Code C=Delete Code J=Edit SE" W Z "RTN","DGPTFM",85,0) W ! S Z="Procedure Records:" W Z S Z=" T=Add PR R=Delete PR P=Add Code Q=Delete Code E=Edit PR" W Z "RTN","DGPTFM",86,0) W ! S Z="801:" W Z S Z=" I=Add 801 Y=Delete 801 N=Add CPT G=Delete CPT F=Edit 801" W Z K Z "RTN","DGPTFM",87,0) W !," ^=Abort to Continue:<",DGNUM,">// " R ANS:DTIME K DGNUM "RTN","DGPTFM",88,0) A S Z="^C Delete Code^A Add Code^O Add Code^P Add NOP^S Add SE^D Delete Code^M Add PM^X Delete PM^Z Delete SE^J Edit SE^Q Delete NOP^V Edit Move^" "RTN","DGPTFM",89,0) S Z=Z_"T Add PR^R Delete PR^E Edit PR^I Add 801^Y Delete 801^N Add CPT^G Delete CPT^F Edit 801" "RTN","DGPTFM",90,0) I 'DGPTFE S $P(Z,U,8,9)="M Edit treat Spec/PM" "RTN","DGPTFM",91,0) S X=ANS G Q^DGPTF:ANS="^" G ^DGPTFJ:ANS?1"^".E S (A,X)=ANS,X=$E(X,1) D IN^DGHELP "RTN","DGPTFM",92,0) I $P(^DGPT(PTF,0),U,4),X'="","IYNGF"[X W !,"***WARNING: This is a Fee Basis PTF record*** 801 encounters are not allowed." H 3 G DGPTFM "RTN","DGPTFM",93,0) I ANS="" S (ST,ST1)=J+2 D:$D(DGZSUR) WR G @($S($D(DGZDIAG):"NDG",$D(DGZSER):"NSR",$D(DGZPRO):"NPR",$D(DGZSUR):"EN^DGPTFM0",+DGZPRF-1'=$P(DGZPRF,U,3):"NPS",1:"DONE")) "RTN","DGPTFM",94,0) G HELP^DGPTFM1A:%=-1 S Z=$L(A)-1 G @(X_$S(X="X":"",1:"^DGPTFM1")) "RTN","DGPTFM",95,0) PRV I $D(^VA(200,L,0)) W $P(^(0),U) Q "RTN","DGPTFM",96,0) W L Q "RTN","DGPTFM",97,0) X ; "RTN","DGPTFM",98,0) I 'Z S:PM=1 RC=1 G X1:PM=1 W !!,"Delete Patient move <1",$S(PM<3:"",1:"-"_(PM-1)),">: " R RC:DTIME G ^DGPTFM:RC["^"!(RC="") "RTN","DGPTFM",99,0) E S RC=$E(A,2,99) W ! "RTN","DGPTFM",100,0) I +RC'=RC!('$D(M(RC))) W !!,"Enter the record # to delete from the PTF file, 1",$S(PM<3:"",1:"-"_(PM-1)) S Z=0 G X "RTN","DGPTFM",101,0) X1 I +M(RC)=1 W !,*7,"Cannot delete discharge movement",! H 3 G ^DGPTFM "RTN","DGPTFM",102,0) S DIE="^DGPT("_PTF_",""M"",",DP=45.02,DR=".01///@",DA(1)=PTF,DA=+M(RC) D ^DIE K DR W " ",RC,"-DELETED***" H 2 G ^DGPTFM "RTN","DGPTFM",103,0) Z W @DGVI,Z,@DGVO Q "RTN","DGPTFM",104,0) EN D WR G EN^DGPTFM0 "RTN","DGPTFM3") 0^2^B16822857^B16699199 "RTN","DGPTFM3",1,0) DGPTFM3 ;ALB/ADL - MASTER CPT RECORD ENTER/EDIT PART 2 ;5/5/05 7:35am "RTN","DGPTFM3",2,0) ;;5.3;Registration;**517,590,594,635,696**;Aug 13, 1993 "RTN","DGPTFM3",3,0) REQ ;CHECK FOR REQUIRED FIELDS IN CPT RECORDS. RECORDS MISSING ONE OR MORE REQUIRED FIELDS ARE DELETED. "RTN","DGPTFM3",4,0) S RFL=0 G REQQ:'$D(DGZPRF(DGZP,0)) "RTN","DGPTFM3",5,0) I '$P(^DGPT(PTF,"C",DGZPRF(DGZP,0),0),U,3) S DA(1)=PTF,DA=DGPSM,DIK="^DGPT("_PTF_",""C""," D G REQQ "RTN","DGPTFM3",6,0) .D ^DIK K DA W !!,"No CPT record has been filed because no performing provider was specified." S RFL=1 "RTN","DGPTFM3",7,0) S (I,FCPT)=0 D RESEQ(PTF) "RTN","DGPTFM3",8,0) F J=1:1 S I=$O(^DGCPT(46,"C",PTF,I)) Q:'I D:+^DGCPT(46,I,1)=+DGZPRF(DGZP)&'$G(^(9)) "RTN","DGPTFM3",9,0) .I $P(^DGCPT(46,I,0),U,4) S FCPT=1 Q "RTN","DGPTFM3",10,0) .S DA=I,DIK="^DGCPT(46,",CPT=+^DGCPT(46,I,0) D ^DIK "RTN","DGPTFM3",11,0) .W !!,"CPT " S N=$$CPT^ICPTCOD(CPT,$$GETDATE^ICDGTDRG(PTF)) W $P(N,U,2)," ",$P(N,U,3)," not filed because no diagnosis 1 was entered." "RTN","DGPTFM3",12,0) .S RFL=1 "RTN","DGPTFM3",13,0) I FCPT K FCPT,I,J,N G REQQ "RTN","DGPTFM3",14,0) S DA(1)=PTF,DA=DGZPRF(DGZP,0),DIK="^DGPT("_PTF_",""C""," "RTN","DGPTFM3",15,0) D ^DIK K DA W !!,"No CPT record has been filed because no CPT codes were filed." S RFL=1 K FCPT,I,J,N "RTN","DGPTFM3",16,0) REQQ ;D RESEQ(PTF) "RTN","DGPTFM3",17,0) Q ;REQ "RTN","DGPTFM3",18,0) RESEQ(PTF) ;A subroutine to check if a DGN in the DGCPT global has been deleted and the other DGN's need "RTN","DGPTFM3",19,0) ;to be moved down in sequence to fill the "gap" in the global "RTN","DGPTFM3",20,0) N REC,CPTINFO,DGNARAY "RTN","DGPTFM3",21,0) S REC=0 "RTN","DGPTFM3",22,0) F S REC=$O(^DGCPT(46,"C",PTF,REC)) Q:REC="" K DGNARAY S CPTINFO=^DGCPT(46,REC,0) D "RTN","DGPTFM3",23,0) . F J=4:1:7,15:1:18 S DGNARAY(J)=$P(CPTINFO,U,J) "RTN","DGPTFM3",24,0) . I $$CHKGAP(.DGNARAY) D RESEQDGN(.CPTINFO,.DGNARAY) S ^DGCPT(46,REC,0)=CPTINFO "RTN","DGPTFM3",25,0) Q ;RESEQ "RTN","DGPTFM3",26,0) CHKGAP(DGNARAY) ;Function call to determine if an inside DGN code has been deleted "RTN","DGPTFM3",27,0) ;Back up in the DGNARAY array until a non-null DGN ien is found, then continuing backwards, "RTN","DGPTFM3",28,0) ;if a null ien is located, that means that an "inside" DGN was deleted "RTN","DGPTFM3",29,0) S SEQ=999,END=1,MISSING=0 "RTN","DGPTFM3",30,0) F S SEQ=$O(DGNARAY(SEQ),-1) Q:SEQ=""!MISSING D "RTN","DGPTFM3",31,0) . I DGNARAY(SEQ)'="" S END=1 Q "RTN","DGPTFM3",32,0) . I DGNARAY(SEQ)="",END=1 S MISSING=1 "RTN","DGPTFM3",33,0) Q MISSING "RTN","DGPTFM3",34,0) ; "RTN","DGPTFM3",35,0) RESEQDGN(CPTINFO,DGNARAY) ;Subroutine to shift down DGN codes to replace any inside DGN's that were deleted by the user "RTN","DGPTFM3",36,0) ; "RTN","DGPTFM3",37,0) N I "RTN","DGPTFM3",38,0) S SEQ="" K NOTNULL "RTN","DGPTFM3",39,0) F S SEQ=$O(DGNARAY(SEQ)) Q:SEQ="" I DGNARAY(SEQ)'="" S NOTNULL(SEQ)=DGNARAY(SEQ) "RTN","DGPTFM3",40,0) K DGNARAY S SEQ="" "RTN","DGPTFM3",41,0) F I=4:1:7,15:1:18 S DGNARAY(I)="" "RTN","DGPTFM3",42,0) F I=4:1:7,15:1:18 S SEQ=$O(NOTNULL(SEQ)) Q:SEQ="" S DGNARAY(I)=NOTNULL(SEQ) "RTN","DGPTFM3",43,0) F I=4:1:7,15:1:18 S $P(CPTINFO,U,I)=$G(DGNARAY(I)) "RTN","DGPTFM3",44,0) K NOTNULL "RTN","DGPTFM3",45,0) Q ;RESEQDGN "RTN","DGPTFM3",46,0) PF S PTF=D0,DFN=+^DGPT(D0,0) D MOB^DGPTFM2 S PS2=0,J=+DGZPRF "RTN","DGPTFM3",47,0) G END:'$P(DGZPRF,U,3) "RTN","DGPTFM3",48,0) LOOP S Y=+DGZPRF(J),DGSTRT=$S(+$P(DGZPRF,U,4):$P(DGZPRF,U,4),1:4),DGLST=0 "RTN","DGPTFM3",49,0) D CL^SDCO21(DFN,+DGZPRF(J),"",.SDCLY),ICDINFO^DGAPI(DFN,PTF),XREF^DGPTFM21 ; load SCI info and DGN's for this service date "RTN","DGPTFM3",50,0) D D^DGPTUTL W !,J,"-CPT Capture Date/Time: ",Y W:($P(DGZPRF,U,2)-1!($G(PGBRK))) " (cont.)" "RTN","DGPTFM3",51,0) I $P(DGZPRF(J),U,2) W !,?5,"Referring or Ordering Provider: " S L=$P(DGZPRF(J),U,2) D PRV^DGPTFM "RTN","DGPTFM3",52,0) W !,?5,"Rendering Provider: " S L=$P(DGZPRF(J),U,3) D PRV^DGPTFM "RTN","DGPTFM3",53,0) I $P(DGZPRF(J),U,5) W !,?5,"Rendering Location: ",$P($G(^SC($P(DGZPRF(J),U,5),0)),U) "RTN","DGPTFM3",54,0) S (L1,PGBRK)=0 "RTN","DGPTFM3",55,0) F K1=$P(DGZPRF,U,2):1 Q:'$D(DGZPRF(J,K1)) I '$G(DGZPRF(J,K1,9)) D Q:$Y+$G(DGZPRF(J,K1+1,1))>16!($G(PGBRK)) "RTN","DGPTFM3",56,0) . S PS2=PS2+1,K=K1 W !,?2,PS2," " D CPT^DGPTUTL1 "RTN","DGPTFM3",57,0) . W !,?4 S $P(DS,"-",27)="" W DS," Related Diagnosis ",DS "RTN","DGPTFM3",58,0) . F L1=DGSTRT:1:11 S DGLOC=$S(L1<8:L1,1:L1+7),CD=$P(DGZPRF(J,K1),U,DGLOC) I CD D I $Y+$G(CKSCI)>16 S PGBRK=1 Q "RTN","DGPTFM3",59,0) . . S N=$$ICDDX^ICDCODE(CD,$$GETDATE^ICDGTDRG(PTF)),N=$S(N:$P(N,U,2,99),1:"") "RTN","DGPTFM3",60,0) . . S CD=$P(N,U) W !,?8,CD," ",$P(N,U,3) "RTN","DGPTFM3",61,0) . . D CKSCI^DGPTFM($P(DGZPRF(J,K1),U,DGLOC)) "RTN","DGPTFM3",62,0) . S PS2(PS2)=J_U_K1,CD=1,DGLOC=0,DGSTRT=4 "RTN","DGPTFM3",63,0) I L1'=11,$S(L1<8:$P($G(DGZPRF(J,K1)),U,L1+1,7),1:"")_$P($G(DGZPRF(J,K1)),U,$S(L1<8:15,1:L1+8),18)?."^" S L1=11 "RTN","DGPTFM3",64,0) I L1=11 S $P(DGZPRF,U,1,2)=$S($D(DGZPRF(J,K1+1)):J_U_(K1+1),1:J+1_U_1),$P(DGZPRF,U,4)="",PGBRK=0 "RTN","DGPTFM3",65,0) E S $P(DGZPRF,U,1,2)=J_U_K1,$P(DGZPRF,U,4)=L1+1 "RTN","DGPTFM3",66,0) S J=+DGZPRF I $D(DGZPRF(J)) D HEAD^DGPTFMO G LOOP "RTN","DGPTFM3",67,0) END I $E(IOST)="C" W ! S DIR(0)="E" D ^DIR K DIR "RTN","DGPTFM3",68,0) K I,K1,L1,CD,N Q "RTN","DGPTR1") 0^3^B25846829^B25729227 "RTN","DGPTR1",1,0) DGPTR1 ;ALB/MTC - PTF VERIFICATION ; 01 MAR 91 @0800 "RTN","DGPTR1",2,0) ;;5.3;Registration;**58,247,338,342,423,415,565,678,696**;Aug 13, 1993 "RTN","DGPTR1",3,0) START S T=$E(Y,2,3),T=$S(T=40&($E(Y,28)="P"):"P40",1:T),ERR=$P($T(@("T"_T)),";;",2,999),W=$P($T(@(T)),";;",2,999),F=31 D L "RTN","DGPTR1",4,0) I T=70 S ERR=$P($T(T701),";;",2,999),W=$P($T(701),";;",2,999),F=72 D L "RTN","DGPTR1",5,0) D @("D"_T) Q "RTN","DGPTR1",6,0) K DGFILL "RTN","DGPTR1",7,0) Q "RTN","DGPTR1",8,0) ; "RTN","DGPTR1",9,0) L F H=1:1 S DGO=$P(W,U,H) Q:'DGO F Z=1:1:$P(DGO,";",3) S DGL=$P(DGLOGIC,U,+DGO),X=$E(Y,F) D @("ERR:"_DGL) S F=F+1 "RTN","DGPTR1",10,0) Q "RTN","DGPTR1",11,0) ; "RTN","DGPTR1",12,0) T10 ;;1:NAME^2:SOURCE OF ADM^3:TRANS FAC.^4:SOURCE OF PAY^5:POW^6:MARITAL ST^7:SEX^8:DOB^9:POS^10:VIETNAM^11:ION RADIATION^12:RESIDENCE^13:MEANS TEST^14:INCOME^15:MST^16:COMBAT VET^17:CV END DT^18:PROJ 112/SHAD^19:ERI "RTN","DGPTR1",13,0) ; "RTN","DGPTR1",14,0) T70 ;;1:DT OF DISP.^2:DISCH BD SEC^3:TYPE OF DIS^4:OUT TREAT^5:VA AUS^6:PL OF DIS^7:REC FAC^8:ASIH DAYS^9:NOT USED^10:C&P STAT^11:DXLS^12:ONLY DX^13:PHY CDR "RTN","DGPTR1",15,0) ;T701 is part 2 of T70 "RTN","DGPTR1",16,0) T701 ;;1:PHY SPEC^2:%SC^3:LEGION^4:SUICIDE^5:DRUG^6:AXIS-IV^7:AXIS-V^8:SC^9:EXP^10:MST^11:HNC^12:ETHNICITY^13:RACE^14:COMBAT VET "RTN","DGPTR1",17,0) ; "RTN","DGPTR1",18,0) T50 ;;1:DT OF MVMT^2:LOSING BD SEC CDR^3:LOSING BD SEC^4:LEAVE DAYS^5:PASS DAYS^6:SCI^7:DIAG^8:DOCTOR'S SSN^9:PHY CDR^10:PHY SPEC^11:DISCHARGE STAT^^^^^16:LEGION^17:SUICIDE^18:DRUG^19:AXIS-IV^20:AXIS-V^21:SC^22:EXP^23:MST^24:HNC "RTN","DGPTR1",19,0) ; "RTN","DGPTR1",20,0) T53 ;;1:DATE OF PHYSICAL MOVEMENT^2:LOSING PHYSICAL CDR^3:LOSING PHYSICAL SPECIALTY^4:TR SPECIALTY CDR^5:TR SPECIALTY^6:LEAVE DAYS^7:PASS DAYS^8:DOCTOR'S SSN (NOT USED) "RTN","DGPTR1",21,0) ; "RTN","DGPTR1",22,0) T40 ;;1:DATE OF SURGERY^2:SURG SPEC.^3:CAT CHIEF SURGEON^4:CAT FIRST ASS^5:ANEST. TECH.^6:SOURCE OF PAY^7:OP CODE^8:DOCTOR'S SSN (NOT USED)^^^^^13:TRANSPLANT STATUS "RTN","DGPTR1",23,0) ; "RTN","DGPTR1",24,0) TP40 ;;1:OP CODE "RTN","DGPTR1",25,0) ; "RTN","DGPTR1",26,0) T60 ;;1:DATE OF PROCEDURE^2:LOSING BD SEC^3:DIALYSIS TYPE^4:NUMBER OF TREATMENTS^5:PROCEDURE CODE "RTN","DGPTR1",27,0) ; "RTN","DGPTR1",28,0) LOGIC ;;X'?.N^X'?.A&(X'=" ")^X'=" "^X'?.N&(X'=" ")^X'?.A&(X'=" ")^0^X'?.N&(X'="X")^X'=" "&(X'="P")^X="E"^X="Y"^X=" "^X'="A"&(X'=" ")^(X'?.A)&(X'?.N)&(X'=" ")^(X'?.N)&('$P(DG0,U,4))^((T1)&(X'=" "))!(('T1)&(X'?.N)&('$P(DG0,U,4))) "RTN","DGPTR1",29,0) ; "RTN","DGPTR1",30,0) ; edit check# ; edit field ; # x check preformed ; display error name # "RTN","DGPTR1",31,0) 10 ;;6;;12;1^2;1;1;1^5;1;1;1^1;2;1;2^2;2;1;2^4;3;3;3^6;;3;3^4;4;1;4^6;5;1;5^2;6;1;6^2;7;1;7^1;8;8;8^6;;1;9^11;9;1;9^4;10;1;10^4;10;1;11^1;11;5;12^7;11;5;12^2;12;1;13^6;;1;13^1;;6;14^2;;1;15^1;;1;16^4;;6;17^3;;1;18^5;;1;19^3;;29 "RTN","DGPTR1",32,0) ; "RTN","DGPTR1",33,0) 70 ;;1;1;10;1^1;2;2;2^1;3;1;3^4;4;1;4^4;5;1;5^6;;1;6^4;7;3;7^6;;3;7^4;8;3;8^6;9;1;9^1;10;1;10^9;11;1;11^11;11;2;11^6;;3;11^10;11;1;11^6;;1;12^15;;6;13 "RTN","DGPTR1",34,0) ;701 is part 2 of 70 "RTN","DGPTR1",35,0) 701 ;;15;;2;1^1;;3;2^4;;1;3^4;;1;4^12;;1;5^4;;3;5^4;;1;6^4;;4;7^4;;1;8^5;;3;9^5;;1;10^5;;1;11^13;12;2;12^13;13;12;13^5;;1;14^3;;17 "RTN","DGPTR1",36,0) ; "RTN","DGPTR1",37,0) 50 ;;1;1;10;1^1;;6;2^1;3;2;3^1;4;3;4^1;5;3;5^6;;1;6^11;7;3;7^6;;32;7^6;;9;8^14;;6;9^14;;2;10^6;;1;11^4;;1;16^4;;1;17^12;;1;18^4;;3;18^4;;1;19^4;;4;20^4;;1;21^5;;3;22^5;;1;23^5;;1;24 "RTN","DGPTR1",38,0) ; "RTN","DGPTR1",39,0) 53 ;;1;;10;1^1;;6;2^1;;2;3^1;;6;4^1;;2;5^1;;3;6^1;;3;7^3;;9;8^3;;54; "RTN","DGPTR1",40,0) ; "RTN","DGPTR1",41,0) 40 ;;1;1;10;1^1;2;2;2^11;3;1;3^4;4;1;4^6;5;1;5^4;6;1;6^11;7;2;7^6;;3;7^3;7;2;7^6;;5;7^3;7;2;7^6;;5;7^3;7;2;7^6;;5;7^3;7;2;7^6;;5;7^3;7;2;7^3;;9;8^4;;1;13^3;;34; "RTN","DGPTR1",42,0) ; "RTN","DGPTR1",43,0) P40 ;;8;;1;^3;;11;^11;1;2;1^6;;3;1^3;1;2;1^6;;5;1^3;;2;1^6;;5;1^3;;2;1^6;;5;1^3;;2;1^6;;5;1^3;;2;1^3;;48 "RTN","DGPTR1",44,0) ; "RTN","DGPTR1",45,0) 60 ;;1;1;10;1^1;2;2;2^4;3;1;3^4;4;3;4^11;5;3;5^6;;32;5^3;;44 "RTN","DGPTR1",46,0) ; "RTN","DGPTR1",47,0) ERR S DGERR=1 "RTN","DGPTR1",48,0) W !,T,$S(T["H":" ",1:$E(Y,4))," " "RTN","DGPTR1",49,0) W:"45"[$E(T,1) $E(Y,31,32),"-",$E(Y,33,34),"-",$E(Y,35,36),"@",$E(Y,37,40) "RTN","DGPTR1",50,0) W ?25,$P($P(ERR,U,$P(DGO,";",4)),":",2),?40,"COL.",F," VALUE: ",$S($E(Y,F)=" ":"BLANK",1:$E(Y,F)) "RTN","DGPTR1",51,0) S I=$S('$D(I):1,I>0:I,1:1),^(I)=$S($D(^UTILITY("DG",$J,T_$S(T["H":"",1:$E(Y,4)),I)):^(I),1:U) I $P(DGO,";",2),^(I)'[(U_$P(DGO,";",2)_U) S ^(I)=^(I)_$P(DGO,";",2)_U "RTN","DGPTR1",52,0) Q "RTN","DGPTR1",53,0) ; "RTN","DGPTR1",54,0) D10 I $E(Y,66)="Z" S (F,H)=68,W="11;10;1;10" D L "RTN","DGPTR1",55,0) I $P(^DGPT(J,0),"^",4),$P(^(0),"^",10)="U",$D(^DGPT(J,70)),+^(70)>2890700 S F=79,DGO="2;12;1;12" D ERR "RTN","DGPTR1",56,0) Q "RTN","DGPTR1",57,0) ; "RTN","DGPTR1",58,0) D40 Q "RTN","DGPTR1",59,0) DP40 Q "RTN","DGPTR1",60,0) D70 I "467"'[$E(Y,43) S F=44,W="4;4;1;4^1;5;1;5^11;6;1;6" D L "RTN","DGPTR1",61,0) Q "RTN","DGPTR1",62,0) D50 I "A0"[$P(DG0,U,5)!("A4"[$P(DG0,U,5))!('$D(^DGPT(J,70))) S W="11;6;1;6",F=55 D L "RTN","DGPTR1",63,0) I $D(^DGPT(J,70)),$S(T1:1,1:+^(70)>2871000) S W="11;6;1;6",F=55 D L "RTN","DGPTR1",64,0) I $E(Y,4)=1 S W="9;7;1;7",F=56 D L "RTN","DGPTR1",65,0) I I=1,'T1 S W="1;11;1;11",F=108 D L "RTN","DGPTR1",66,0) Q "RTN","DGPTR1",67,0) D53 Q "RTN","DGPTR1",68,0) D60 I $E(Y,43) S F=44,W="1;4;3;4" D L "RTN","DGPTR1",69,0) Q "RTN","DGPTR1",70,0) HEAD S ERR="1:SSN^2:ADMISSION DATE^3:FACILITY #",W="8;1;1;1^1;1;9;1^1;2;10;2^1;3;3;3^6;;3;3",F=5,DGLOGIC=$P($T(LOGIC),";;",2),T="HEADER" "RTN","DGPTR1",71,0) D L "RTN","DGPTR1",72,0) Q "RTN","DGPTR1",73,0) LOG S DGLOGIC=$P($T(LOGIC),";;",2) "RTN","DGPTR1",74,0) Q "RTN","DGPTR1",75,0) CEN S T=70,ERR=$P($T(T70),";;",2),W=$P($T(70),";;",2,999),W="13;9;1;9"_$P(W,"13;9;1;9",2,999),F=56 D L "RTN","DGPTR1",76,0) S ERR=$P($T(T701),";;",2),W=$P($T(701),";;",2,999),F=72 D L "RTN","DGPTR1",77,0) Q "VER") 8.0^22.0 "BLD",6571,6) ^634 **END** **END**