Released DG*5.3*701 SEQ #627 Extracted from mail message **KIDS**:DG*5.3*701^ **INSTALL NAME** DG*5.3*701 "BLD",6723,0) DG*5.3*701^REGISTRATION^0^3060505^y "BLD",6723,1,0) ^^3^3^3060505^ "BLD",6723,1,1,0) This patch deals with non-VA PTF census problems, the inability to "BLD",6723,1,2,0) select certain ICD9 codes on the 501 screen of PTF Load/Edit, and a "BLD",6723,1,3,0) system error when transferring patients. "BLD",6723,4,0) ^9.64PA^^ "BLD",6723,"KRN",0) ^9.67PA^8989.52^19 "BLD",6723,"KRN",.4,0) .4 "BLD",6723,"KRN",.401,0) .401 "BLD",6723,"KRN",.402,0) .402 "BLD",6723,"KRN",.403,0) .403 "BLD",6723,"KRN",.5,0) .5 "BLD",6723,"KRN",.84,0) .84 "BLD",6723,"KRN",3.6,0) 3.6 "BLD",6723,"KRN",3.8,0) 3.8 "BLD",6723,"KRN",9.2,0) 9.2 "BLD",6723,"KRN",9.8,0) 9.8 "BLD",6723,"KRN",9.8,"NM",0) ^9.68A^3^3 "BLD",6723,"KRN",9.8,"NM",1,0) DGPTC1^^0^B26128925 "BLD",6723,"KRN",9.8,"NM",2,0) DGPTF5^^0^B2939565 "BLD",6723,"KRN",9.8,"NM",3,0) DGPTFJC^^0^B47957071 "BLD",6723,"KRN",9.8,"NM","B","DGPTC1",1) "BLD",6723,"KRN",9.8,"NM","B","DGPTF5",2) "BLD",6723,"KRN",9.8,"NM","B","DGPTFJC",3) "BLD",6723,"KRN",19,0) 19 "BLD",6723,"KRN",19.1,0) 19.1 "BLD",6723,"KRN",101,0) 101 "BLD",6723,"KRN",409.61,0) 409.61 "BLD",6723,"KRN",771,0) 771 "BLD",6723,"KRN",870,0) 870 "BLD",6723,"KRN",8989.51,0) 8989.51 "BLD",6723,"KRN",8989.52,0) 8989.52 "BLD",6723,"KRN",8994,0) 8994 "BLD",6723,"KRN","B",.4,.4) "BLD",6723,"KRN","B",.401,.401) "BLD",6723,"KRN","B",.402,.402) "BLD",6723,"KRN","B",.403,.403) "BLD",6723,"KRN","B",.5,.5) "BLD",6723,"KRN","B",.84,.84) "BLD",6723,"KRN","B",3.6,3.6) "BLD",6723,"KRN","B",3.8,3.8) "BLD",6723,"KRN","B",9.2,9.2) "BLD",6723,"KRN","B",9.8,9.8) "BLD",6723,"KRN","B",19,19) "BLD",6723,"KRN","B",19.1,19.1) "BLD",6723,"KRN","B",101,101) "BLD",6723,"KRN","B",409.61,409.61) "BLD",6723,"KRN","B",771,771) "BLD",6723,"KRN","B",870,870) "BLD",6723,"KRN","B",8989.51,8989.51) "BLD",6723,"KRN","B",8989.52,8989.52) "BLD",6723,"KRN","B",8994,8994) "BLD",6723,"QUES",0) ^9.62^^ "BLD",6723,"REQB",0) ^9.611^4^3 "BLD",6723,"REQB",2,0) DG*5.3*643^1 "BLD",6723,"REQB",3,0) DG*5.3*669^1 "BLD",6723,"REQB",4,0) DG*5.3*635^1 "BLD",6723,"REQB","B","DG*5.3*635",4) "BLD",6723,"REQB","B","DG*5.3*643",2) "BLD",6723,"REQB","B","DG*5.3*669",3) "MBREQ") 0 "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) 701^3060505 "PKG",5,22,1,"PAH",1,1,0) ^^3^3^3060505 "PKG",5,22,1,"PAH",1,1,1,0) This patch deals with non-VA PTF census problems, the inability to "PKG",5,22,1,"PAH",1,1,2,0) select certain ICD9 codes on the 501 screen of PTF Load/Edit, and a "PKG",5,22,1,"PAH",1,1,3,0) system error when transferring patients. "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") 3 "RTN","DGPTC1") 0^1^B26128925^B24771658 "RTN","DGPTC1",1,0) DGPTC1 ;ALN/MJK - Census Record Processing; JAN 27, 2005 "RTN","DGPTC1",2,0) ;;5.3;Registration;**37,413,643,701**;Aug 13, 1993 "RTN","DGPTC1",3,0) ; "RTN","DGPTC1",4,0) CEN ; -- determine if PTF rec is current Census rec "RTN","DGPTC1",5,0) ; input: PTF := ptf rec # "RTN","DGPTC1",6,0) ; DGPMCA := corres. adm (non-fee) "RTN","DGPTC1",7,0) ; DGPMAN := 0th node of corrs adm " "RTN","DGPTC1",8,0) ;output: DGCI := census rec # "RTN","DGPTC1",9,0) ; DGCST := census rec status "RTN","DGPTC1",10,0) ; DGCN := census date entry to 45.86 "RTN","DGPTC1",11,0) ; "RTN","DGPTC1",12,0) K DGCST,DGCI,DGCN,DGCN0,DGFEE "RTN","DGPTC1",13,0) S DGFEE=0 "RTN","DGPTC1",14,0) G CENQ:'$D(^DGPT(PTF,0)) N DFN S DGPTF0=^(0),DFN=+DGPTF0 "RTN","DGPTC1",15,0) ;G CENQ:$P(DGPTF0,U,4) "RTN","DGPTC1",16,0) D CEN^DGPTUTL I DGCN0=""!(DT'>DGCN0) K DGCN G CENQ "RTN","DGPTC1",17,0) ;I $P(DGPTF0,U,4) D FEE G CENQ ;DG*701 reposition line "RTN","DGPTC1",18,0) S DGT=$P(DGCN0,U)_".9" I '$P(DGPTF0,U,4) D WARD I 'Y K DGCN G CENQ "RTN","DGPTC1",19,0) ;if Fee Basis quit if admit > census date or admit < census date if disch "RTN","DGPTC1",20,0) I $P(DGPTF0,U,4)=1,$P(DGPTF0,U,2)>DGT G CENQ "RTN","DGPTC1",21,0) I $P(DGPTF0,U,4)=1,+$P($G(^DGPT(PTF,70)),U),$P(DGPTF0,U,2)0 K DGERR D ^DGPTF2 G CLSQ "RTN","DGPTC1",62,0) ;-- do austin edits "RTN","DGPTC1",63,0) ; "RTN","DGPTC1",64,0) D ^DGPTAE I DGERR>0 K DGERR D ^DGPTF2 G CLSQ "RTN","DGPTC1",65,0) K DGERR,^TMP("AEDIT",$J),DGACNT "RTN","DGPTC1",66,0) I $P(^DGPT(PTF,0),U,4) S DGFEE=1 D FEE1 G CLSQ:'DGCI "RTN","DGPTC1",67,0) I $P(^DGPT(PTF,0),U,4)'=1 D CREATE G CLSQ:'DGCI "RTN","DGPTC1",68,0) S DR="7////"_DUZ_";8///T",DA=DGCI,DIE="^DGPT(" D ^DIE K DIE,DR "RTN","DGPTC1",69,0) S (X,DINUM)=DGCI,DIC(0)="L",DIC="^DGP(45.84,",DIC("DR")="2///NOW;3////"_DUZ "RTN","DGPTC1",70,0) K DD,DO D FILE^DICN K DIC,DINUM "RTN","DGPTC1",71,0) F I=0,.11,.52,.321,.32,57,.3 S:$D(^DPT(DFN,I)) ^DGP(45.84,DGCI,$S(I=0:10,1:I))=^DPT(DFN,I) "RTN","DGPTC1",72,0) W !,"****** CENSUS CLOSED OUT ******" D HANG^DGPTUTL "RTN","DGPTC1",73,0) S DGCST=1 "RTN","DGPTC1",74,0) CLSQ S DGPTFMT=DGPTFMTX K DGPTFMTX,DGFEE Q "RTN","DGPTC1",75,0) ; "RTN","DGPTC1",76,0) CREATE ; -- create census record "RTN","DGPTC1",77,0) W !,"Creating Census Record..." "RTN","DGPTC1",78,0) S Y=$P(^DGPT(PTF,0),U,2) D CREATE^DGPTFCR G CREATEQ:Y<0 S DGCI=+Y W "#",DGCI "RTN","DGPTC1",79,0) S DGEND=+^DG(45.86,DGCN,0)_".2359",DGBEG=+$P(^(0),U,5) "RTN","DGPTC1",80,0) S ^DGPT(DGCI,0)=$P(^DGPT(PTF,0),U,1,10)_"^2^"_PTF_"^"_DGCN,DGCSUF=$P(^(0),U,5) "RTN","DGPTC1",81,0) ;S ^DGPT(DGCI,0)=$P(^DGPT(PTF,0),U,1,5)_"^1^"_$P(^DGPT(PTF,0),U,7,10)_"^2^"_PTF_"^"_DGCN,DGCSUF=$P(^(0),U,5) "RTN","DGPTC1",82,0) S Y=DGEND D BS^DGPTC2 S X="",$P(X,U)=DGEND,$P(X,U,14)=Y "RTN","DGPTC1",83,0) I $D(^DGPT(PTF,70)) S Y=^(70) F I=8,9,10 S $P(X,U,I)=$P(Y,U,I) "RTN","DGPTC1",84,0) S ^DGPT(DGCI,70)=X D ASIH "RTN","DGPTC1",85,0) I $D(^DGPT(PTF,101)) S ^DGPT(DGCI,101)=^DGPT(PTF,101) "RTN","DGPTC1",86,0) F NODE="M","P","S",535 F I=0:0 S I=$O(^DGPT(PTF,NODE,I)) Q:'I I $D(^DGPT(PTF,NODE,I,0)) S X=^(0) D @("SET"_NODE_"^DGPTC2") "RTN","DGPTC1",87,0) K DA,DIKLM S DA=DGCI,DIK="^DGPT(" D IX1^DIK "RTN","DGPTC1",88,0) CREATEQ K X,Y,DGCSUF,DGBEG,DGEND Q "RTN","DGPTC1",89,0) ; "RTN","DGPTC1",90,0) FEE1 ; -- create census record for fee record "RTN","DGPTC1",91,0) W !,"Creating Census Record..." "RTN","DGPTC1",92,0) S Y=$P(^DGPT(PTF,0),U,2) D CREATE^DGPTFCR G CREATEQ:Y<0 S DGCI=+Y W "#",DGCI "RTN","DGPTC1",93,0) S DGEND=+^DG(45.86,DGCN,0)_".2359",DGBEG=+$P(^(0),U,5) "RTN","DGPTC1",94,0) S ^DGPT(DGCI,0)=$P(^DGPT(PTF,0),U,1,10)_"^2^"_PTF_"^"_DGCN,DGCSUF=$P(^(0),U,5) "RTN","DGPTC1",95,0) I $D(^DGPT(PTF,70)) S ^DGPT(DGCI,70)=^DGPT(PTF,70) "RTN","DGPTC1",96,0) S $P(^DGPT(DGCI,70),U)=DGEND "RTN","DGPTC1",97,0) I $D(^DGPT(PTF,101)) S ^DGPT(DGCI,101)=^DGPT(PTF,101) "RTN","DGPTC1",98,0) F NODE="M","P","S",535 F I=0:0 S I=$O(^DGPT(PTF,NODE,I)) Q:'I I $D(^DGPT(PTF,NODE,I,0)) S X=^(0) D @("SET"_NODE_"^DGPTC2") "RTN","DGPTC1",99,0) K DA,DIKLM S DA=DGCI,DIK="^DGPT(" D IX1^DIK "RTN","DGPTC1",100,0) FEE1Q K X,Y,DGCSUF,DGBEG,DGEND Q "RTN","DGPTC1",101,0) OPEN ; -- re-open census rec by deleting "RTN","DGPTC1",102,0) S DGPTIFN=DGCI D OPEN^DGPTFDEL S (DGCI,DGCST)=0 "RTN","DGPTC1",103,0) K DGPTIFN Q "RTN","DGPTC1",104,0) ; "RTN","DGPTC1",105,0) WARD ; -- ward @ census d/t for an adm(even if nhcu/dom adm that is ASIH) "RTN","DGPTC1",106,0) ; input: DGPMCA := corres adm "RTN","DGPTC1",107,0) ; DGPMAN := corres adm 0th node "RTN","DGPTC1",108,0) ; output: Y := ward ptr or null "RTN","DGPTC1",109,0) ; "RTN","DGPTC1",110,0) N MVT,M "RTN","DGPTC1",111,0) S Y="" "RTN","DGPTC1",112,0) I +DGPMAN>DGT Q "RTN","DGPTC1",113,0) I $D(^DGPM(+$P(DGPMAN,U,17),0)),+^(0)0 D CONFIG^LEXSET("ICD",,$$GETDATE^ICDGTDRG(DA(1))) "RTN","DGPTF5",22,0) E D CONFIG^LEXSET("ICD",,$$GETDATE^ICDGTDRG(DA)) "RTN","DGPTF5",23,0) S DIC="^LEX(757.01,",DIC(0)=$S('$L($G(X)):"",1:"")_"EQM" "RTN","DGPTF5",24,0) S DIC("A")="Enter ICD: " "RTN","DGPTF5",25,0) D ^DIC "RTN","DGPTF5",26,0) I Y=-1 S X="" Q "RTN","DGPTF5",27,0) S X=$G(Y(1)) "RTN","DGPTF5",28,0) Q "RTN","DGPTF5",29,0) ICDEN1 ;enter icd codes for DRG "RTN","DGPTF5",30,0) N DIC K X,Y "RTN","DGPTF5",31,0) D CONFIG^LEXSET("ICD",,$G(DGDAT)) "RTN","DGPTF5",32,0) S DIC="^LEX(757.01,",DIC(0)=$S('$L($G(X)):"",1:"")_"EQM" "RTN","DGPTF5",33,0) S DIC("A")=PROMPT "RTN","DGPTF5",34,0) D ^DIC "RTN","DGPTF5",35,0) I Y=-1 S X="" Q "RTN","DGPTF5",36,0) S X=$G(Y(1)) "RTN","DGPTF5",37,0) S Y=$$ICDDX^ICDCODE(X,$G(DGDAT)) "RTN","DGPTF5",38,0) Q "RTN","DGPTFJC") 0^3^B47957071^B46752372 "RTN","DGPTFJC",1,0) DGPTFJC ;ALB/ADL - CLOSED PTF ;7/28/05 1:08pm "RTN","DGPTFJC",2,0) ;;5.3;Registration;**158,510,517,590,636,635,701**;Aug 13, 1993 "RTN","DGPTFJC",3,0) ;;ADL;;Update for CSV Project;;Mar 25, 2003 "RTN","DGPTFJC",4,0) 101 W !,"Enter '^N' for Screen N, RETURN for ,'^' to Abort: //" "RTN","DGPTFJC",5,0) D READ G Q^DGPTF:X=U,^DGPTFM:X="",^DGPTFJ:X?1"^".E D H G 101 "RTN","DGPTFJC",6,0) ; "RTN","DGPTFJC",7,0) H D HELP^DGPTFJ W ! Q "RTN","DGPTFJC",8,0) ; "RTN","DGPTFJC",9,0) MAS W !!,"Enter '^N' for Screen N, RETURN for <",DGNUM,">,'^' to Abort: <",DGNUM,">//" "RTN","DGPTFJC",10,0) D READ G Q^DGPTF:X=U,^DGPTFJ:X?1"^".E "RTN","DGPTFJC",11,0) I X="" S (ST,ST1)=J+2 G @($S($D(DGZDIAG):"NDG",$D(DGZSER):"NSR",$D(DGZPRO):"NPR",$D(DGZSUR):"EN",+DGZPRF-1'=$P(DGZPRF,U,3):"NPS",1:"DONE")_"^DGPTFM") "RTN","DGPTFJC",12,0) D H G MAS "RTN","DGPTFJC",13,0) ; "RTN","DGPTFJC",14,0) 401 S DGNUM=$S($D(S(DGZS0+1)):401_"-"_(DGZS0+1),1:"MAS") "RTN","DGPTFJC",15,0) W !,"Enter '^N' for Screen N, RETURN for <",DGNUM,">,'^' to Abort: <",DGNUM,">//" "RTN","DGPTFJC",16,0) D READ G Q^DGPTF:X=U,NEXM^DGPTFM5:X="",^DGPTFJ:X?1"^".E D H G 401 "RTN","DGPTFJC",17,0) ; "RTN","DGPTFJC",18,0) 501 W !,"Enter '^N' for Screen N, RETURN for <",DGNUM,">,'^' to Abort: <",DGNUM,">//" "RTN","DGPTFJC",19,0) D READ G Q^DGPTF:X=U,NEXM^DGPTFM4:X="",^DGPTFJ:X?1"^".E D H G 501 "RTN","DGPTFJC",20,0) ; "RTN","DGPTFJC",21,0) 601 W !,"Enter '^N' for Screen N, RETURN for <",DGNUM,">,'^' to Abort: <",DGNUM,">//" "RTN","DGPTFJC",22,0) D READ G Q^DGPTF:X=U,NEXP^DGPTFM6:X="",^DGPTFJ:X?1"^".E D H G 601 "RTN","DGPTFJC",23,0) ; "RTN","DGPTFJC",24,0) 701 ; "RTN","DGPTFJC",25,0) G ACT1^DGPTF41 ; new code "RTN","DGPTFJC",26,0) ; "RTN","DGPTFJC",27,0) ;Display screen prompt and process user response for 801 screen "RTN","DGPTFJC",28,0) 801 W !,"Enter '^N' for Screen N, RETURN for <",DGNUM,">,'^' to Abort: <",DGNUM,">//" "RTN","DGPTFJC",29,0) D READ G Q^DGPTF:X=U,NEXP^DGPTFM2:X="",^DGPTFJ:X?1"^".E D H G 801 "RTN","DGPTFJC",30,0) READ ; -- read X "RTN","DGPTFJC",31,0) R X:DTIME S:'$T X="^",DGPTOUT="" "RTN","DGPTFJC",32,0) Q "RTN","DGPTFJC",33,0) ; "RTN","DGPTFJC",34,0) EN ; DG*636 "RTN","DGPTFJC",35,0) ;;S K=$S($D(K):K,1:1),DGER=0 S DGPTDAT=$$GETDATE^ICDGTDRG(DA(1)),DGPTTMP=$$ICDDX^ICDCODE(+Y,DGPTDAT) I +DGPTTMP=-1!('$P(DGPTTMP,U,10)) S DGER=1 Q "RTN","DGPTFJC",36,0) S K=$S($D(K):K,1:1),DGER=0 S DGPTDAT=$$GETDATE^ICDGTDRG(DA(1)) "RTN","DGPTFJC",37,0) ;if there is a disch and a previous movement, if disch "RTN","DGPTFJC",38,0) ;is >Oct 1 (next FY) and movement 0930,$E(DGPTMVDT,4,7)<1001 S DGPTDAT=DGPTMVDT Q "RTN","DGPTFJC",46,0) .;if different calendar year "RTN","DGPTFJC",47,0) .I ($E(DGPTDAT,1,3)-$E(DGPTMVDT,1,3))>1 S DGPTDAT=DGPTMVDT Q "RTN","DGPTFJC",48,0) .I $E(DGPTMVDT,4,7)<1001 S DGPTDAT=DGPTMVDT Q "RTN","DGPTFJC",49,0) .I $E(DGPTDAT,4,7)>0930 S DGPTDAT=DGPTMVDT Q "RTN","DGPTFJC",50,0) I $G(DGPMT) K M(DGZM0),DGZM0 ; DG*701 "RTN","DGPTFJC",51,0) S DGPTTMP=$$ICDDX^ICDCODE(+Y,DGPTDAT) I +DGPTTMP=-1!('$P(DGPTTMP,U,10)) S DGER=1 Q "RTN","DGPTFJC",52,0) ;end DG*636 "RTN","DGPTFJC",53,0) ;=================================================================== "RTN","DGPTFJC",54,0) I $P(DGPTTMP,U,11)]""&($P(DGPTTMP,U,11)'=$S($D(^DPT(+^DGPT(DA(1),0),0)):$P(^(0),U,2),1:"M")) W:K<24 !,$P(DGPTTMP,U,2)," can only be used with ",$S($P(DGPTTMP,U,11)="F":"FEMALES",1:"MALES") S K=K+1,DGER=1 Q "RTN","DGPTFJC",55,0) S %=$P(^DGPT(DA(1),"M",DA,0),U,DGI) I $D(^DGPT(DA(1),"M","AC",Y,DA)),%'=Y S DGER=1 Q "RTN","DGPTFJC",56,0) F I=0:0 S I=$O(^ICD9(+Y,"N",I)) Q:I'>0 I $D(^DGPT(DA(1),"M","AC",I,DA)),%'=I W !,"Cannot use ",$S($D(^ICD9(+Y,0)):$P(^(0),U),1:"")," with ",$S($D(^ICD9(I,0)):$P(^(0),U),1:"") S DGER=1 Q "RTN","DGPTFJC",57,0) Q:DGER S DG1=1 F I=0:0 S I=$O(^ICD9(+Y,"R",I)) Q:I'>0 S DG1=0 I $D(^DGPT(DA(1),"M","AC",I,DA)),%'=I S DG1=1 Q "RTN","DGPTFJC",58,0) I 'DG1 W !,$S(+DGPTTMP>0&('$P(DGPTTMP,U,10)):$P(DGPTTMP,U,2),1:"")," requires additional code." "RTN","DGPTFJC",59,0) Q "RTN","DGPTFJC",60,0) EN1 S K=$S($D(K):K,1:1),DGER=0,DGPTDAT=$$GETDATE^ICDGTDRG(DA(1)),DGICD0=$$ICDOP^ICDCODE(+Y,DGPTDAT) I +DGICD0,0!('$P(DGICD0,U,10)) S DGER=1 Q "RTN","DGPTFJC",61,0) I $P(DGICD0,U,11)]""&($P(DGICD0,U,11)'=$S($D(^DPT(+^DGPT(DA(1),0),0)):$P(^(0),U,2),1:"M")) W:K<24 !,$P(DGICD0,U,2)," can only be used with ",$S($P(DGICD0,U,11)="F":"FEMALES",1:"MALES") S K=K+1,DGER=1 Q "RTN","DGPTFJC",62,0) S %=$P(^DGPT(DA(1),DGSB,DA,0),U,DGI) I $D(^DGPT(DA(1),DGSB,DGCR,Y,DA)),%'=Y S DGER=1 W !,"Cannot enter the same code more than once within a ",$S(DGSB="S":"401",1:"601")," transaction" Q "RTN","DGPTFJC",63,0) F I=0:0 S I=$O(^ICD0(+Y,"N",I)) Q:I'>0 I $D(^DGPT(DA(1),DGSB,DGCR,I,DA)),%'=I S DGPTTMP2=$$ICDOP^ICDCODE(I,DGPTDAT) W !,"Cannot use ",$P(DGICD0,U,2)," with ",$S(+DGPTTMP2>0:$P(DGPTTMP2,U,2),1:"") S DGER=1 Q "RTN","DGPTFJC",64,0) Q:DGER S DG1=1 F I=0:0 S I=$O(^ICD0(+Y,"R",I)) Q:I'>0 S DG1=0 I $D(^DGPT(DA(1),DGSB,DGCR,I,DA)),%'=I S DG1=1 Q "RTN","DGPTFJC",65,0) I 'DG1 W !,$P(DGICD0,U,2)," requires additional code." "RTN","DGPTFJC",66,0) Q "RTN","DGPTFJC",67,0) EN2 S K=$S($D(K):K,1:1),DGER=0,DGPTTMP=$$ICDOP^ICDCODE(+Y,$$GETDATE^ICDGTDRG(DA)) I +DGPTTMP<0!('$P(DGPTTMP,U,10)) S DGER=1 Q "RTN","DGPTFJC",68,0) I $P(DGPTTMP,U,11)]""&($P(DGPTTMP,U,11)'=$S($D(^DPT(+^DGPT(DA,0),0)):$P(^(0),U,2),1:"M")) W:K<24 !,$P(DGPTTMP,U,2)," can only be used with ",$S($P(DGPTTMP,U,11)="F":"FEMALES",1:"MALES") S K=K+1,DGER=1 Q "RTN","DGPTFJC",69,0) S L=$P($S($D(^DGPT((DA),"401P")):^("401P"),1:0),U,1,5),%=$P(L,U,DGI),L=$P(L,U,1,DGI-1)_U_$P(L,U,DGI+1,5) I L[Y S DGER=1 Q "RTN","DGPTFJC",70,0) Q "RTN","DGPTFJC",71,0) EN3 S K=$S($D(K):K,1:1),DGER=0,DGPTTMP=$$ICDDX^ICDCODE(+Y,$$GETDATE^ICDGTDRG(DA)) I +DGPTTMP<0!('$P(DGPTTMP,U,10)) S DGER=1 Q "RTN","DGPTFJC",72,0) I DGI=1,$P(DGPTTMP,U,5) S DGER=1 Q "RTN","DGPTFJC",73,0) I $P(DGPTTMP,U,11)]""&($P(DGPTTMP,U,11)'=$S($D(^DPT(+^DGPT(DA,0),0)):$P(^(0),U,2),1:"M")) W:K<24 !,$P(DGPTTMP,U,2)," can only be used with ",$S($P(DGPTTMP,U,11)="F":"FEMALES",1:"MALES") S K=K+1,DGER=1 Q "RTN","DGPTFJC",74,0) S %=$S($D(^DGPT(DA,70)):^(70),1:""),%=U_$P(%,U,10)_U_$P(%,U,16,24)_U "RTN","DGPTFJC",75,0) S:$G(^DGPT(DA,71))'="" %=%_^(71)_U S $P(%,U,DGI+1)=U I %[(U_+Y_U) S DGER=1 Q "RTN","DGPTFJC",76,0) F I=0:0 S I=$O(^ICD9(+Y,"N",I)) Q:I'>0 I %[(U_I_U) S DGPTTMP2=$$ICDDX^ICDCODE(I,DGPTDAT) W !,"Cannot use ",$P($G(DGPTTMP),U,2)," with ",$S(+DGPTTMP2>0:$P(DGPTTMP2,U,2),1:"") S DGER=1 Q "RTN","DGPTFJC",77,0) Q:DGER S DG1=1 F I=0:0 S I=$O(^ICD9(+Y,"R",I)) Q:I'>0 S DG1=0 I %[(U_I_U) S DG1=1 Q "RTN","DGPTFJC",78,0) I 'DG1 W !,$S(+DGPTTMP>0:$P(DGPTTMP,U,2),1:"")," requires additional code." "RTN","DGPTFJC",79,0) Q "RTN","DGPTFJC",80,0) EN4 S K=$S($D(K):K,1:1),DGER=0,N=$$ICDDX^ICDCODE(+Y,$$GETDATE^ICDGTDRG(DA)) I N<0!'$P(N,U,10) S DGER=1 Q "RTN","DGPTFJC",81,0) I DGI=1,$P(N,U,5) S DGER=1 Q "RTN","DGPTFJC",82,0) I $P(N,U,11)]""&($P(N,U,11)'=$S($D(^DPT(+^DGPT(DA(2),0),0)):$P(^(0),U,2),1:"M")) W:K<24 !,$P(N,U,2)," can only be used with ",$S($P(N,U,11)="F":"FEMALES",1:"MALES") S K=K+1,DGER=1 Q "RTN","DGPTFJC",83,0) S %=$S($D(^DGPT(DA(2),"C",DA(1),"CPT",DA,0)):^(0),1:""),%=U_$P(%,U,4,7)_U,$P(%,U,DGI+1)=U I %[(U_+Y_U) S DGER=1 Q "RTN","DGPTFJC",84,0) F I=0:0 S I=$O(^ICD9(+Y,"N",I)) Q:I'>0 I %[(U_I_U) W !,"Cannot use ",$S($D(^ICD9(+Y,0)):$P(^(0),U),1:"")," with ",$S($D(^ICD9(I,0)):$P(^(0),U),1:"") S DGER=1 Q "RTN","DGPTFJC",85,0) Q:DGER S DG1=1 F I=0:0 S I=$O(^ICD9(+Y,"R",I)) Q:I'>0 S DG1=0 I %[(U_I_U) S DG1=1 Q "RTN","DGPTFJC",86,0) I 'DG1 W !,$P(N,U,2)," requires additional code." Q "RTN","DGPTFJC",87,0) Q "RTN","DGPTFJC",88,0) EN5 S K=$S($D(K):K,1:1),DGER=0,DGPTTMP=$$ICDDX^ICDCODE(+Y,+DGZPRF(DGZP)) I +DGPTTMP<0!('$P(DGPTTMP,U,10)) S DGER=1 Q "RTN","DGPTFJC",89,0) I $P(DGPTTMP,U,11)]""&($P(DGPTTMP,U,11)'=$S($D(^DPT(+^DGPT(PTF,0),0)):$P(^(0),U,2),1:"M")) W:K<24 !,$P(DGPTTMP,U,2)," can only be used with ",$S($P(DGPTTMP,U,11)="F":"FEMALES",1:"MALES") S K=K+1,DGER=1 Q "RTN","DGPTFJC",90,0) S K=^DGCPT(46,DA,0) I $P(K,U,4,7)_U_$P(K,U,15,18)[Y S DGER=1 Q "RTN","DGPTFJC",91,0) Q "RTN","DGPTFJC",92,0) EN6 I $P($G(^(0)),U,2)?.N S DGER=1 Q "RTN","DGPTFJC",93,0) S DGER=0,N=$$CPT^ICPTCOD(+Y,$$GETDATE^ICDGTDRG(DA)) I N<0!'$P(N,"^",7) S DGER=1 Q "RTN","DGPTFJC",94,0) S L=0 F S L=$O(^DGCPT(46,L)) Q:L'>0 I +$G(^(L,1))=DGPRD,$P(^(1),U,3)=PTF,+^(0)=Y,'$G(^(9)) S DGER=1 Q "RTN","DGPTFJC",95,0) K L Q "VER") 8.0^22.0 "BLD",6723,6) ^627 **END** **END**