DGPTFJC ;ALB/ADL - CLOSED PTF ;7/28/05 1:08pm
;;5.3;PIMS;**158,510,517,590,636,635,701,729,1015,1016**;JUN 30, 2012;Build 20
;;ADL;;Update for CSV Project;;Mar 25, 2003
101 W !,"Enter '^N' for Screen N, RETURN for <MAS>,'^' to Abort: <MAS>//"
D READ G Q^DGPTF:X=U,^DGPTFM:X="",^DGPTFJ:X?1"^".E D H G 101
;
H D HELP^DGPTFJ W ! Q
;
MAS W !!,"Enter '^N' for Screen N, RETURN for <",DGNUM,">,'^' to Abort: <",DGNUM,">//"
D READ G Q^DGPTF:X=U,^DGPTFJ:X?1"^".E
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")
D H G MAS
;
401 S DGNUM=$S($D(S(DGZS0+1)):401_"-"_(DGZS0+1),1:"MAS")
W !,"Enter '^N' for Screen N, RETURN for <",DGNUM,">,'^' to Abort: <",DGNUM,">//"
D READ G Q^DGPTF:X=U,NEXM^DGPTFM5:X="",^DGPTFJ:X?1"^".E D H G 401
;
501 W !,"Enter '^N' for Screen N, RETURN for <",DGNUM,">,'^' to Abort: <",DGNUM,">//"
D READ G Q^DGPTF:X=U,NEXM^DGPTFM4:X="",^DGPTFJ:X?1"^".E D H G 501
;
601 W !,"Enter '^N' for Screen N, RETURN for <",DGNUM,">,'^' to Abort: <",DGNUM,">//"
D READ G Q^DGPTF:X=U,NEXP^DGPTFM6:X="",^DGPTFJ:X?1"^".E D H G 601
;
701 ;
G ACT1^DGPTF41 ; new code
;
;Display screen prompt and process user response for 801 screen
801 W !,"Enter '^N' for Screen N, RETURN for <",DGNUM,">,'^' to Abort: <",DGNUM,">//"
D READ G Q^DGPTF:X=U,NEXP^DGPTFM2:X="",^DGPTFJ:X?1"^".E D H G 801
READ ; -- read X
R X:DTIME S:'$T X="^",DGPTOUT=""
Q
;
EN ; DG*636
;;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
S K=$S($D(K):K,1:1),DGER=0 S DGPTDAT=$$GETDATE^ICDGTDRG(DA(1))
;if there is a disch and a previous movement, if disch
;is >Oct 1 (next FY) and movement <Oct 1, then use the movement date
I $G(DGZM0)="" S DGZM0=1,M(DGZM0)="0^" ; to prevent sys err from TD5^DGPTTS2 and ptf quick load (DG*701/729)
N DGPTMVDT I DGPTDAT=$P($G(^DGPT(DA(1),70)),U,1)&(DGPTDAT=$P($G(^DGPT(DA(1),"M",1,0)),U,10))&($D(M(DGZM0)))&($P($G(M(DGZM0)),U)'=1) S DGPTMVDT=$P($G(^DGPT(DA(1),"M",2,0)),U,10)
;next line is if using "Add a code" in MAS screen
I '$G(DGPTMVDT)&($D(DGADD))&($G(DGMOV)'=1) S DGPTMVDT=$P($G(^DGPT(DA(1),"M",2,0)),U,10)
I $G(DGPTMVDT) D
.;if same calendar year
.I $E(DGPTDAT,1,3)=$E(DGPTMVDT,1,3),$E(DGPTDAT,4,7)>0930,$E(DGPTMVDT,4,7)<1001 S DGPTDAT=DGPTMVDT Q
.;if different calendar year
.I ($E(DGPTDAT,1,3)-$E(DGPTMVDT,1,3))>1 S DGPTDAT=DGPTMVDT Q
.I $E(DGPTMVDT,4,7)<1001 S DGPTDAT=DGPTMVDT Q
.I $E(DGPTDAT,4,7)>0930 S DGPTDAT=DGPTMVDT Q
I $G(DGPMT)!$G(DGQWK) K M(DGZM0),DGZM0 ; DG*701/729
S DGPTTMP=$$ICDDX^ICDCODE(+Y,DGPTDAT) I +DGPTTMP=-1!('$P(DGPTTMP,U,10)) S DGER=1 Q
;end DG*636
;===================================================================
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
S %=$P(^DGPT(DA(1),"M",DA,0),U,DGI) I $D(^DGPT(DA(1),"M","AC",Y,DA)),%'=Y S DGER=1 Q
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
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
I 'DG1 W !,$S(+DGPTTMP>0&('$P(DGPTTMP,U,10)):$P(DGPTTMP,U,2),1:"")," requires additional code."
Q
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
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
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
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
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
I 'DG1 W !,$P(DGICD0,U,2)," requires additional code."
Q
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
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
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
Q
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
I DGI=1,$P(DGPTTMP,U,5) S DGER=1 Q
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
S %=$S($D(^DGPT(DA,70)):^(70),1:""),%=U_$P(%,U,10)_U_$P(%,U,16,24)_U
S:$G(^DGPT(DA,71))'="" %=%_^(71)_U S $P(%,U,DGI+1)=U I %[(U_+Y_U) S DGER=1 Q
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
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
I 'DG1 W !,$S(+DGPTTMP>0:$P(DGPTTMP,U,2),1:"")," requires additional code."
Q
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
I DGI=1,$P(N,U,5) S DGER=1 Q
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
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
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
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
I 'DG1 W !,$P(N,U,2)," requires additional code." Q
Q
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
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
S K=^DGCPT(46,DA,0) I $P(K,U,4,7)_U_$P(K,U,15,18)[Y S DGER=1 Q
Q
EN6 I $P($G(^(0)),U,2)?.N S DGER=1 Q
S DGER=0,N=$$CPT^ICPTCOD(+Y,$$GETDATE^ICDGTDRG(DA)) I N<0!'$P(N,"^",7) S DGER=1 Q
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
K L Q
DGPTFJC ;ALB/ADL - CLOSED PTF ;7/28/05 1:08pm
+1 ;;5.3;PIMS;**158,510,517,590,636,635,701,729,1015,1016**;JUN 30, 2012;Build 20
+2 ;;ADL;;Update for CSV Project;;Mar 25, 2003
101 WRITE !,"Enter '^N' for Screen N, RETURN for <MAS>,'^' to Abort: <MAS>//"
+1 DO READ
IF X=U
GOTO Q^DGPTF
IF X=""
GOTO ^DGPTFM
IF X?1"^".E
GOTO ^DGPTFJ
DO H
GOTO 101
+2 ;
H DO HELP^DGPTFJ
WRITE !
QUIT
+1 ;
MAS WRITE !!,"Enter '^N' for Screen N, RETURN for <",DGNUM,">,'^' to Abort: <",DGNUM,">//"
+1 DO READ
IF X=U
GOTO Q^DGPTF
IF X?1"^".E
GOTO ^DGPTFJ
+2 IF X=""
SET (ST,ST1)=J+2
GOTO @($SELECT($DATA(DGZDIAG):"NDG",$DATA(DGZSER):"NSR",$DATA(DGZPRO):"NPR",$DATA(DGZSUR):"EN",+DGZPRF-1'=$PIECE(DGZPRF,U,3):"NPS",1:"DONE")_"^DGPTFM")
+3 DO H
GOTO MAS
+4 ;
401 SET DGNUM=$SELECT($DATA(S(DGZS0+1)):401_"-"_(DGZS0+1),1:"MAS")
+1 WRITE !,"Enter '^N' for Screen N, RETURN for <",DGNUM,">,'^' to Abort: <",DGNUM,">//"
+2 DO READ
IF X=U
GOTO Q^DGPTF
IF X=""
GOTO NEXM^DGPTFM5
IF X?1"^".E
GOTO ^DGPTFJ
DO H
GOTO 401
+3 ;
501 WRITE !,"Enter '^N' for Screen N, RETURN for <",DGNUM,">,'^' to Abort: <",DGNUM,">//"
+1 DO READ
IF X=U
GOTO Q^DGPTF
IF X=""
GOTO NEXM^DGPTFM4
IF X?1"^".E
GOTO ^DGPTFJ
DO H
GOTO 501
+2 ;
601 WRITE !,"Enter '^N' for Screen N, RETURN for <",DGNUM,">,'^' to Abort: <",DGNUM,">//"
+1 DO READ
IF X=U
GOTO Q^DGPTF
IF X=""
GOTO NEXP^DGPTFM6
IF X?1"^".E
GOTO ^DGPTFJ
DO H
GOTO 601
+2 ;
701 ;
+1 ; new code
GOTO ACT1^DGPTF41
+2 ;
+3 ;Display screen prompt and process user response for 801 screen
801 WRITE !,"Enter '^N' for Screen N, RETURN for <",DGNUM,">,'^' to Abort: <",DGNUM,">//"
+1 DO READ
IF X=U
GOTO Q^DGPTF
IF X=""
GOTO NEXP^DGPTFM2
IF X?1"^".E
GOTO ^DGPTFJ
DO H
GOTO 801
READ ; -- read X
+1 READ X:DTIME
IF '$TEST
SET X="^"
SET DGPTOUT=""
+2 QUIT
+3 ;
EN ; DG*636
+1 ;;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
+2 SET K=$SELECT($DATA(K):K,1:1)
SET DGER=0
SET DGPTDAT=$$GETDATE^ICDGTDRG(DA(1))
+3 ;if there is a disch and a previous movement, if disch
+4 ;is >Oct 1 (next FY) and movement <Oct 1, then use the movement date
+5 ; to prevent sys err from TD5^DGPTTS2 and ptf quick load (DG*701/729)
IF $GET(DGZM0)=""
SET DGZM0=1
SET M(DGZM0)="0^"
+6 NEW DGPTMVDT
IF DGPTDAT=$PIECE($GET(^DGPT(DA(1),70)),U,1)&(DGPTDAT=$PIECE($GET(^DGPT(DA(1),"M",1,0)),U,10))&($DATA(M(DGZM0)))&($PIECE($GET(M(DGZM0)),U)'=1)
SET DGPTMVDT=$PIECE($GET(^DGPT(DA(1),"M",2,0)),U,10)
+7 ;next line is if using "Add a code" in MAS screen
+8 IF '$GET(DGPTMVDT)&($DATA(DGADD))&($GET(DGMOV)'=1)
SET DGPTMVDT=$PIECE($GET(^DGPT(DA(1),"M",2,0)),U,10)
+9 IF $GET(DGPTMVDT)
Begin DoDot:1
+10 ;if same calendar year
+11 IF $EXTRACT(DGPTDAT,1,3)=$EXTRACT(DGPTMVDT,1,3)
IF $EXTRACT(DGPTDAT,4,7)>0930
IF $EXTRACT(DGPTMVDT,4,7)<1001
SET DGPTDAT=DGPTMVDT
QUIT
+12 ;if different calendar year
+13 IF ($EXTRACT(DGPTDAT,1,3)-$EXTRACT(DGPTMVDT,1,3))>1
SET DGPTDAT=DGPTMVDT
QUIT
+14 IF $EXTRACT(DGPTMVDT,4,7)<1001
SET DGPTDAT=DGPTMVDT
QUIT
+15 IF $EXTRACT(DGPTDAT,4,7)>0930
SET DGPTDAT=DGPTMVDT
QUIT
End DoDot:1
+16 ; DG*701/729
IF $GET(DGPMT)!$GET(DGQWK)
KILL M(DGZM0),DGZM0
+17 SET DGPTTMP=$$ICDDX^ICDCODE(+Y,DGPTDAT)
IF +DGPTTMP=-1!('$PIECE(DGPTTMP,U,10))
SET DGER=1
QUIT
+18 ;end DG*636
+19 ;===================================================================
+20 IF $PIECE(DGPTTMP,U,11)]""&($PIECE(DGPTTMP,U,11)'=$SELECT($DATA(^DPT(+^DGPT(DA(1),0),0)):$PIECE(^(0),U,2),1:"M"))
IF K<24
WRITE !,$PIECE(DGPTTMP,U,2)," can only be used with ",$SELECT($PIECE(DGPTTMP,U,11)="F":"FEMALES",1:"MALES")
SET K=K+1
SET DGER=1
QUIT
+21 SET %=$PIECE(^DGPT(DA(1),"M",DA,0),U,DGI)
IF $DATA(^DGPT(DA(1),"M","AC",Y,DA))
IF %'=Y
SET DGER=1
QUIT
+22 FOR I=0:0
SET I=$ORDER(^ICD9(+Y,"N",I))
IF I'>0
QUIT
IF $DATA(^DGPT(DA(1),"M","AC",I,DA))
IF %'=I
WRITE !,"Cannot use ",$SELECT($DATA(^ICD9(+Y,0)):$PIECE(^(0),U),1:"")," with ",$SELECT($DATA(^ICD9(I,0)):$PIECE(^(0),U),1:"")
SET DGER=1
QUIT
+23 IF DGER
QUIT
SET DG1=1
FOR I=0:0
SET I=$ORDER(^ICD9(+Y,"R",I))
IF I'>0
QUIT
SET DG1=0
IF $DATA(^DGPT(DA(1),"M","AC",I,DA))
IF %'=I
SET DG1=1
QUIT
+24 IF 'DG1
WRITE !,$SELECT(+DGPTTMP>0&('$PIECE(DGPTTMP,U,10)):$PIECE(DGPTTMP,U,2),1:"")," requires additional code."
+25 QUIT
EN1 SET K=$SELECT($DATA(K):K,1:1)
SET DGER=0
SET DGPTDAT=$$GETDATE^ICDGTDRG(DA(1))
SET DGICD0=$$ICDOP^ICDCODE(+Y,DGPTDAT)
IF +DGICD0
IF 0!('$PIECE(DGICD0,U,10))
SET DGER=1
QUIT
+1 IF $PIECE(DGICD0,U,11)]""&($PIECE(DGICD0,U,11)'=$SELECT($DATA(^DPT(+^DGPT(DA(1),0),0)):$PIECE(^(0),U,2),1:"M"))
IF K<24
WRITE !,$PIECE(DGICD0,U,2)," can only be used with ",$SELECT($PIECE(DGICD0,U,11)="F":"FEMALES",1:"MALES")
SET K=K+1
SET DGER=1
QUIT
+2 SET %=$PIECE(^DGPT(DA(1),DGSB,DA,0),U,DGI)
+3 ;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
+4 FOR I=0:0
SET I=$ORDER(^ICD0(+Y,"N",I))
IF I'>0
QUIT
IF $DATA(^DGPT(DA(1),DGSB,DGCR,I,DA))
IF %'=I
SET DGPTTMP2=$$ICDOP^ICDCODE(I,DGPTDAT)
WRITE !,"Cannot use ",$PIECE(DGICD0,U,2)," with ",$SELECT(+DGPTTMP2>0:$PIECE(DGPTTMP2,U,2),1:"")
SET DGER=1
QUIT
+5 IF DGER
QUIT
SET DG1=1
FOR I=0:0
SET I=$ORDER(^ICD0(+Y,"R",I))
IF I'>0
QUIT
SET DG1=0
IF $DATA(^DGPT(DA(1),DGSB,DGCR,I,DA))
IF %'=I
SET DG1=1
QUIT
+6 IF 'DG1
WRITE !,$PIECE(DGICD0,U,2)," requires additional code."
+7 QUIT
EN2 SET K=$SELECT($DATA(K):K,1:1)
SET DGER=0
SET DGPTTMP=$$ICDOP^ICDCODE(+Y,$$GETDATE^ICDGTDRG(DA))
IF +DGPTTMP<0!('$PIECE(DGPTTMP,U,10))
SET DGER=1
QUIT
+1 IF $PIECE(DGPTTMP,U,11)]""&($PIECE(DGPTTMP,U,11)'=$SELECT($DATA(^DPT(+^DGPT(DA,0),0)):$PIECE(^(0),U,2),1:"M"))
IF K<24
WRITE !,$PIECE(DGPTTMP,U,2)," can only be used with ",$SELECT($PIECE(DGPTTMP,U,11)="F":"FEMALES",1:"MALES")
SET K=K+1
SET DGER=1
QUIT
+2 SET L=$PIECE($SELECT($DATA(^DGPT((DA),"401P")):^("401P"),1:0),U,1,5)
SET %=$PIECE(L,U,DGI)
SET L=$PIECE(L,U,1,DGI-1)_U_$PIECE(L,U,DGI+1,5)
IF L[Y
SET DGER=1
QUIT
+3 QUIT
EN3 SET K=$SELECT($DATA(K):K,1:1)
SET DGER=0
SET DGPTTMP=$$ICDDX^ICDCODE(+Y,$$GETDATE^ICDGTDRG(DA))
IF +DGPTTMP<0!('$PIECE(DGPTTMP,U,10))
SET DGER=1
QUIT
+1 IF DGI=1
IF $PIECE(DGPTTMP,U,5)
SET DGER=1
QUIT
+2 IF $PIECE(DGPTTMP,U,11)]""&($PIECE(DGPTTMP,U,11)'=$SELECT($DATA(^DPT(+^DGPT(DA,0),0)):$PIECE(^(0),U,2),1:"M"))
IF K<24
WRITE !,$PIECE(DGPTTMP,U,2)," can only be used with ",$SELECT($PIECE(DGPTTMP,U,11)="F":"FEMALES",1:"MALES")
SET K=K+1
SET DGER=1
QUIT
+3 SET %=$SELECT($DATA(^DGPT(DA,70)):^(70),1:"")
SET %=U_$PIECE(%,U,10)_U_$PIECE(%,U,16,24)_U
+4 IF $GET(^DGPT(DA,71))'=""
SET %=%_^(71)_U
SET $PIECE(%,U,DGI+1)=U
IF %[(U_+Y_U)
SET DGER=1
QUIT
+5 FOR I=0:0
SET I=$ORDER(^ICD9(+Y,"N",I))
IF I'>0
QUIT
IF %[(U_I_U)
SET DGPTTMP2=$$ICDDX^ICDCODE(I,DGPTDAT)
WRITE !,"Cannot use ",$PIECE($GET(DGPTTMP),U,2)," with ",$SELECT(+DGPTTMP2>0:$PIECE(DGPTTMP2,U,2),1:"")
SET DGER=1
QUIT
+6 IF DGER
QUIT
SET DG1=1
FOR I=0:0
SET I=$ORDER(^ICD9(+Y,"R",I))
IF I'>0
QUIT
SET DG1=0
IF %[(U_I_U)
SET DG1=1
QUIT
+7 IF 'DG1
WRITE !,$SELECT(+DGPTTMP>0:$PIECE(DGPTTMP,U,2),1:"")," requires additional code."
+8 QUIT
EN4 SET K=$SELECT($DATA(K):K,1:1)
SET DGER=0
SET N=$$ICDDX^ICDCODE(+Y,$$GETDATE^ICDGTDRG(DA))
IF N<0!'$PIECE(N,U,10)
SET DGER=1
QUIT
+1 IF DGI=1
IF $PIECE(N,U,5)
SET DGER=1
QUIT
+2 IF $PIECE(N,U,11)]""&($PIECE(N,U,11)'=$SELECT($DATA(^DPT(+^DGPT(DA(2),0),0)):$PIECE(^(0),U,2),1:"M"))
IF K<24
WRITE !,$PIECE(N,U,2)," can only be used with ",$SELECT($PIECE(N,U,11)="F":"FEMALES",1:"MALES")
SET K=K+1
SET DGER=1
QUIT
+3 SET %=$SELECT($DATA(^DGPT(DA(2),"C",DA(1),"CPT",DA,0)):^(0),1:"")
SET %=U_$PIECE(%,U,4,7)_U
SET $PIECE(%,U,DGI+1)=U
IF %[(U_+Y_U)
SET DGER=1
QUIT
+4 FOR I=0:0
SET I=$ORDER(^ICD9(+Y,"N",I))
IF I'>0
QUIT
IF %[(U_I_U)
WRITE !,"Cannot use ",$SELECT($DATA(^ICD9(+Y,0)):$PIECE(^(0),U),1:"")," with ",$SELECT($DATA(^ICD9(I,0)):$PIECE(^(0),U),1:"")
SET DGER=1
QUIT
+5 IF DGER
QUIT
SET DG1=1
FOR I=0:0
SET I=$ORDER(^ICD9(+Y,"R",I))
IF I'>0
QUIT
SET DG1=0
IF %[(U_I_U)
SET DG1=1
QUIT
+6 IF 'DG1
WRITE !,$PIECE(N,U,2)," requires additional code."
QUIT
+7 QUIT
EN5 SET K=$SELECT($DATA(K):K,1:1)
SET DGER=0
SET DGPTTMP=$$ICDDX^ICDCODE(+Y,+DGZPRF(DGZP))
IF +DGPTTMP<0!('$PIECE(DGPTTMP,U,10))
SET DGER=1
QUIT
+1 IF $PIECE(DGPTTMP,U,11)]""&($PIECE(DGPTTMP,U,11)'=$SELECT($DATA(^DPT(+^DGPT(PTF,0),0)):$PIECE(^(0),U,2),1:"M"))
IF K<24
WRITE !,$PIECE(DGPTTMP,U,2)," can only be used with ",$SELECT($PIECE(DGPTTMP,U,11)="F":"FEMALES",1:"MALES")
SET K=K+1
SET DGER=1
QUIT
+2 SET K=^DGCPT(46,DA,0)
IF $PIECE(K,U,4,7)_U_$PIECE(K,U,15,18)[Y
SET DGER=1
QUIT
+3 QUIT
EN6 IF $PIECE($GET(^(0)),U,2)?.N
SET DGER=1
QUIT
+1 SET DGER=0
SET N=$$CPT^ICPTCOD(+Y,$$GETDATE^ICDGTDRG(DA))
IF N<0!'$PIECE(N,"^",7)
SET DGER=1
QUIT
+2 SET L=0
FOR
SET L=$ORDER(^DGCPT(46,L))
IF L'>0
QUIT
IF +$GET(^(L,1))=DGPRD
IF $PIECE(^(1),U,3)=PTF
IF +^(0)=Y
IF '$GET(^(9))
SET DGER=1
QUIT
+3 KILL L
QUIT
