DGPTUTL1 ;ALB/MJK - PTF Utility ;2/1/05 2:20pm
;;5.3;Registration;**33,45,54,517,635,817,850,1057**;Aug 13, 1993;Build 17
;
FLAG ; -- select PTF rec to update xmit flags
S DGMAX=25
W ! S DIC="^DGPT(",DIC(0)="AEMQ",DIC("S")="I '$P(^(0),U,6),$P(^(0),U,11)=1 D CHK^DGPTUTL1 I $D(DGMTY)>9"
D ^DIC K DIC G FLAGQ:+Y<0 S (Y,PTF)=+Y D CHK
F DGMTY=501,535 I $D(DGMTY(DGMTY)) D UP Q:$D(DGOUT)
FLAGQ K DGMAX,DGT,DGADM,DGX,DGA1,DGA,DGMTY,C,DGOUT Q
;
UP ; -- select mvt and update xmit flag
I DGMTY=501 S DIC="^DGPT("_PTF_",""M"",",DIC("S")="I Y'=1"
I DGMTY=535 S DIC="^DGPT("_PTF_",535,",DIC("S")="I Y'=1"
W ! S DIC(0)="AEMQ" D ^DIC S DIE=DIC K DIC
K DGOUT I X["^" S DGOUT=""
I +Y<0 G UPQ
S DA=+Y,DR=17 D ^DIE K DE,DQ G UP
UPQ K DIE,DR Q
;
CHK ;
N T1,T2,C K DGMTY S T1=0,T2=9999999
F DGMTY=501,535 D 501^DGPTFVC2:DGMTY=501,535^DGPTFVC2:DGMTY=535 S:C>DGMAX DGMTY(DGMTY)=""
Q
;
INCOME ;-- load ptf income information
; Use discharge date if available; else use current date/time
D NOW^%DTC
S X=$S($D(^DGPT(PTF,70)):+^(70),1:%),DGX=$S($D(^DGPT(PTF,101)):^(101),1:"")
D INC
G INQ:Y=$P(DGX,U,7)
S DIE="^DGPT(",DA=PTF,DR="101.07////"_Y
D ^DIE
INQ ;
K DGX,DGINCM,DIE,DA,DR,DGI,DG30,DG362,DGT,%
Q
;
INC ;-- load income information Input:X date,Output:Y-income
N DGINCM,DGI,DG30,DG362,DGT,DGX
I '$D(X) S Y="" G INCQ
S Y=+$P($$INCOME^VAFMON(DFN,X),".")
I Y<0 S Y=0
INCQ Q
;
CHQUES ;-- This function will determine if the patient has any of the following
; indicated : AO, IR and EC. If so the array DGEXQ will contain
; DGEXQ(1)="" - AO
; DGEXQ(2)="" - IR
; DGEXQ(3)="" - EC
; Otherwise they will be undefined.
K DGEXQ
S DGEXQ(1)="",DGEXQ(2)="",DGEXQ(3)=""
Q
;
SETTRAN ;-- set transmission if error DGOUT=1, will return XMZ
K DGXMZ
S DGOUTX=0
S Y=$S($P(DGD,".",2)=99:DGSD,1:DGD) X ^DD("DD")
S XMSUB=Y_" "_$P(DGRTY0,U)_" TRANSMISSION ",XMDUZ=.5
D GET^XMA2
I $D(XMZ),XMZ>0 S DGXMZ=XMZ K XMZ G SETQ
W !!,"*** ERROR *** Unable to create Mail Message #... Try again later."
S DGOUTX=1
SETQ ;
Q
;
KVAR ; -- clean up for l/e
K DA,DFN,A,B,I,ANS,DIE,DR,%,%DT,DGPR,DGREL,DGST,DIC,HEAD,H,I,I2,J,K,L,M,N,MT,NU,PTF,DGPTFE,Y,DGZM0,DGZS0,DOB,L1,PT,SEX,AGE,CC,DAM,DOB,DXLS,EXP,NOR,NO,DRG,DRGCAL,DGZSUR,S1,SUR,M1,MOV,P,P1
K DGDX,DGER,DGI,DGINFO,DGLOS,DGNXD,DGP,DGPAS,DGPSV,DGTLOS,DGTY,DIS2,DGJUMP,DGPRD,DGPC,DGDRGNM,DGMOVM,DR,DGQWK,ST1,DGX,DQ,TY,DGRTY,DGRTY0,DGPTFMT,DG,DGA1,DGDC,DGNEXT,RC,DP,POP,DGICD0,DGPROCD,DGPROCI,DGPROCM,DGVAR,DGAD
K TAC,TRS,SD,PD,MDC,NDR,NSD,OR,ORG,T,DGZDIAG,DGZPRO,DGZSER,J1,I1,L2,L3,L4,L5,L6,PM,DGFC,S,M2,PROC,SU,ST,NL,DGDD,SD1,D,DFN,DFN1,DFN2,D0,P2,S2,X,DGNUM,DGN,DGERR,DGVI,DGVO,Z,Z1,DGZ,DGADM,DGNODE,^UTILITY($J),DGCFL
K DGPM2X,DGPMDA,DGPMDCD,DGPMVI,DGAMY,VAERR,VAIP,DGPTSCRN,DGREC,DGHOLD,DG300,DG300A,DG300B,DG701,DGBPC,DGPTIT,DGMOV,DGSUR
K M3,DGLAST,DGMVT,VAIN,DGMPOA,DGDXPOA,XX,ID,DGCR,DGZP,DGSB,M3,PTR,TYPE,DGMV,DGMV0,DGNTARR,DGPMY,DGRM,DGSPACE2,DGDS,DGIDTS ; DG*5.3*1057
K DGPTF,DGDAT,DGPOA,DGPTDAT,DISDATE,DGZPRF,DGPTTMP,DGTMP,ICDDA,ICDPOA,ICDTMP,ICDIEN,ICDX,ICD10ORT,ICD10NIORT,ICD10ORNIT,ICD10SDT,ICDEDT,ICDLABEL,ICDCSYS,ICDRG,VA,VAEL,STR,EFFDATE,IMPDATE,VACNT
Q
;
ELIG ; shows eligibility and disabilities
D ELIG^VADPT W #,!,"Eligibility: "_$P(VAEL(1),"^",2)_$S(+VAEL(3):" SC%: "_$P(VAEL(3),"^",2),1:"")
W !,"Disabilities: " F I=0:0 S I=$O(^DPT(DFN,.372,I)) Q:'I S I1=$S($D(^DPT(DFN,.372,I,0)):^(0),1:"") D:+I1
.S PSDIS=$S($P($G(^DIC(31,+I1,0)),"^")]""&($P($G(^(0)),"^",4)']""):$P(^(0),"^"),$P($G(^DIC(31,+I1,0)),"^",4)]"":$P(^(0),"^",4),1:""),PSCNT=$P(I1,"^",2)
.W:$L(PSDIS_"-"_PSCNT_"% ("_$S($P(I1,"^",3):"SC",1:"NSC")_"), ")+$X>80 !,?15
.W $S($G(PSDIS)]"":PSDIS_"-",1:"")_PSCNT_"% ("_$S($P(I1,"^",3):"SC",1:"NSC")_"), "
.I $Y>22 W !,"PRESS RETURN TO CONTINUE:" R X:DTIME W #
Q
DATE ;EDIT CPT DATE/TIME TO BE AFTER ADMISSION DATE BUT BEFORE DISCHARGE
N DGADM,DGIDS,I ; DG*5.3*1057
S DGADM=$P(^DGPT(DA(1),0),U,2) ; admission date DG*5.3*1057
S DGIDS=$P(^DGPT(DA(1),0),U,14) ; initial date of service DG*5.3*1057
I DGIDS>0,X<DGIDS W !,"Must be on or after initial date of service",! K X Q ; DG*5.3*1057
I DGIDS'>0,X<$$FMADD^XLFDT(DGADM,,-72) W !,"Must be at most 72 hrs prior to admission" K X Q ; DG*5.3*1057
I $G(^(70)),X>^(70) W !,"Not after discharge" K X Q
S I=0 F S I=$O(^DGPT(DA(1),"C",I)) Q:I'>0 I X=+^(I,0) W !,"Cannot change to existing CPT date/time entry" K X Q
Q
SETABX ;SET AB CROSSREFERENCE IN FILE 45
G KILLABX:$P($G(^DGPT(DA(1),"C",DA,0)),U,7)
N BOOL S (DGCPT,BOOL)=0
F S DGCPT=$O(^DGCPT(46,"C",DA(1),DGCPT)) Q:'DGCPT D Q:BOOL
.S BOOL='$G(^DGCPT(46,DGCPT,9))
I 'BOOL K ^DGPT("AB",$E(X,1,30),DA(1),DA)
S ^DGPT("AB",$E(X,1,30),DA(1),DA)="" Q
KILLABX ;KILL AB CROSSREFERENCE IN FILE 45
G SETABX:'$P($G(^DGPT(DA(1),"C",DA,0)),U,7)
K ^DGPT("AB",$E(X,1,30),DA(1),DA) Q
DISP F I=1:1:$P(DGZPRF,U,3) D
.S Y=+DGZPRF(I) D D^DGPTUTL W !,I,?5,Y
Q
HELP W !,"Enter '^' to stop display and edit of data,"
W !,"'^N' to jump to screen #N (appears in upper right of screen as"
W " <N>),",!,"a number to jump to that number 801 screen,"
W " ?? to list the 801 screens,"
W !,"<RET> to continue on to next screen or A-B to edit:"
W !?10,"A-Professional service information",!,?10,"B-Procedure codes",!,"You may also enter any combination of the above, separated by commas (ex:A,B)",! Q
CPT ;DISPLAY CPT CODES AND MODIFIERS
S CPT=+DGZPRF(J,K),N=$$CPT^ICPTCOD(CPT,$$GETDATE^ICDGTDRG(PTF)),N=$S(N>0:$P(N,U,2,99),1:"")
W $P(N,U)," ",$P(N,U,2)
F I=1,2 S MOD=$P(DGZPRF(J,K),U,I+1) D MOD:MOD
W !,?7,"Quantity: ",$P(DGZPRF(J,K),U,14) K I,MOD,N Q
MOD S N=$$MOD^ICPTMOD(MOD,"I",$$GETDATE^ICDGTDRG(PTF)) W !,?7,"CPT Modifier ",I,":",$P(N,U,2)," ",$P(N,U,3)
Q
;
DTIDS ; date check against admission and discharge dates, called from input transform on field 45/14 DG*5.3*1057
N DGADMDT,DGDSCDT
S DGADMDT=$P(^DGPT(DA,0),U,2),DGDSCDT=$P($G(^DGPT(DA,70)),U)
I DGDSCDT'>0 S DGDSCDT=9999999
I X<$$FMADD^XLFDT(DGADMDT,,-72) W !,"Must be at most 72 hrs prior to admission" K X Q
I X>DGDSCDT W !,"Not after discharge" K X
Q
;
DT401 ; date check against admission and discharge dates, called from input transform on field 45.01/.01 DG*5.3*1057
N DGADMDT,DGIDS,DGDSCDT
S DGADMDT=$P(^DGPT(DA(1),0),U,2),DGDSCDT=$P($G(^DGPT(DA(1),70)),U)
S DGIDS=$P(^DGPT(DA(1),0),U,14) ; initial date of service
I DGDSCDT'>0 S DGDSCDT=9999999
I DGIDS>0,X<DGIDS W !,"Must be on or after initial date of service",! K X Q
I DGIDS'>0,X<$$FMADD^XLFDT(DGADMDT,,-72) W !,"Must be at most 72 hrs prior to admission" K X Q
I X>DGDSCDT W !,"Not after discharge" K X
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTUTL1 6696 printed Apr 09, 2024@22:04:17 Page 2
DGPTUTL1 ;ALB/MJK - PTF Utility ;2/1/05 2:20pm
+1 ;;5.3;Registration;**33,45,54,517,635,817,850,1057**;Aug 13, 1993;Build 17
+2 ;
FLAG ; -- select PTF rec to update xmit flags
+1 SET DGMAX=25
+2 WRITE !
SET DIC="^DGPT("
SET DIC(0)="AEMQ"
SET DIC("S")="I '$P(^(0),U,6),$P(^(0),U,11)=1 D CHK^DGPTUTL1 I $D(DGMTY)>9"
+3 DO ^DIC
KILL DIC
if +Y<0
GOTO FLAGQ
SET (Y,PTF)=+Y
DO CHK
+4 FOR DGMTY=501,535
IF $DATA(DGMTY(DGMTY))
DO UP
if $DATA(DGOUT)
QUIT
FLAGQ KILL DGMAX,DGT,DGADM,DGX,DGA1,DGA,DGMTY,C,DGOUT
QUIT
+1 ;
UP ; -- select mvt and update xmit flag
+1 IF DGMTY=501
SET DIC="^DGPT("_PTF_",""M"","
SET DIC("S")="I Y'=1"
+2 IF DGMTY=535
SET DIC="^DGPT("_PTF_",535,"
SET DIC("S")="I Y'=1"
+3 WRITE !
SET DIC(0)="AEMQ"
DO ^DIC
SET DIE=DIC
KILL DIC
+4 KILL DGOUT
IF X["^"
SET DGOUT=""
+5 IF +Y<0
GOTO UPQ
+6 SET DA=+Y
SET DR=17
DO ^DIE
KILL DE,DQ
GOTO UP
UPQ KILL DIE,DR
QUIT
+1 ;
CHK ;
+1 NEW T1,T2,C
KILL DGMTY
SET T1=0
SET T2=9999999
+2 FOR DGMTY=501,535
if DGMTY=501
DO 501^DGPTFVC2
if DGMTY=535
DO 535^DGPTFVC2
if C>DGMAX
SET DGMTY(DGMTY)=""
+3 QUIT
+4 ;
INCOME ;-- load ptf income information
+1 ; Use discharge date if available; else use current date/time
+2 DO NOW^%DTC
+3 SET X=$SELECT($DATA(^DGPT(PTF,70)):+^(70),1:%)
SET DGX=$SELECT($DATA(^DGPT(PTF,101)):^(101),1:"")
+4 DO INC
+5 if Y=$PIECE(DGX,U,7)
GOTO INQ
+6 SET DIE="^DGPT("
SET DA=PTF
SET DR="101.07////"_Y
+7 DO ^DIE
INQ ;
+1 KILL DGX,DGINCM,DIE,DA,DR,DGI,DG30,DG362,DGT,%
+2 QUIT
+3 ;
INC ;-- load income information Input:X date,Output:Y-income
+1 NEW DGINCM,DGI,DG30,DG362,DGT,DGX
+2 IF '$DATA(X)
SET Y=""
GOTO INCQ
+3 SET Y=+$PIECE($$INCOME^VAFMON(DFN,X),".")
+4 IF Y<0
SET Y=0
INCQ QUIT
+1 ;
CHQUES ;-- This function will determine if the patient has any of the following
+1 ; indicated : AO, IR and EC. If so the array DGEXQ will contain
+2 ; DGEXQ(1)="" - AO
+3 ; DGEXQ(2)="" - IR
+4 ; DGEXQ(3)="" - EC
+5 ; Otherwise they will be undefined.
+6 KILL DGEXQ
+7 SET DGEXQ(1)=""
SET DGEXQ(2)=""
SET DGEXQ(3)=""
+8 QUIT
+9 ;
SETTRAN ;-- set transmission if error DGOUT=1, will return XMZ
+1 KILL DGXMZ
+2 SET DGOUTX=0
+3 SET Y=$SELECT($PIECE(DGD,".",2)=99:DGSD,1:DGD)
XECUTE ^DD("DD")
+4 SET XMSUB=Y_" "_$PIECE(DGRTY0,U)_" TRANSMISSION "
SET XMDUZ=.5
+5 DO GET^XMA2
+6 IF $DATA(XMZ)
IF XMZ>0
SET DGXMZ=XMZ
KILL XMZ
GOTO SETQ
+7 WRITE !!,"*** ERROR *** Unable to create Mail Message #... Try again later."
+8 SET DGOUTX=1
SETQ ;
+1 QUIT
+2 ;
KVAR ; -- clean up for l/e
+1 KILL DA,DFN,A,B,I,ANS,DIE,DR,%,%DT,DGPR,DGREL,DGST,DIC,HEAD,H,I,I2,J,K,L,M,N,MT,NU,PTF,DGPTFE,Y,DGZM0,DGZS0,DOB,L1,PT,SEX,AGE,CC,DAM,DOB,DXLS,EXP,NOR,NO,DRG,DRGCAL,DGZSUR,S1,SUR,M1,MOV,P,P1
+2 KILL DGDX,DGER,DGI,DGINFO,DGLOS,DGNXD,DGP,DGPAS,DGPSV,DGTLOS,DGTY,DIS2,DGJUMP,DGPRD,DGPC,DGDRGNM,DGMOVM,DR,DGQWK,ST1,DGX,DQ,TY,DGRTY,DGRTY0,DGPTFMT,DG,DGA1,DGDC,DGNEXT,RC,DP,POP,DGICD0,DGPROCD,DGPROCI,DGPROCM,DGVAR,DGAD
+3 KILL TAC,TRS,SD,PD,MDC,NDR,NSD,OR,ORG,T,DGZDIAG,DGZPRO,DGZSER,J1,I1,L2,L3,L4,L5,L6,PM,DGFC,S,M2,PROC,SU,ST,NL,DGDD,SD1,D,DFN,DFN1,DFN2,D0,P2,S2,X,DGNUM,DGN,DGERR,DGVI,DGVO,Z,Z1,DGZ,DGADM,DGNODE,^UTILITY($JOB),DGCFL
+4 KILL DGPM2X,DGPMDA,DGPMDCD,DGPMVI,DGAMY,VAERR,VAIP,DGPTSCRN,DGREC,DGHOLD,DG300,DG300A,DG300B,DG701,DGBPC,DGPTIT,DGMOV,DGSUR
+5 ; DG*5.3*1057
KILL M3,DGLAST,DGMVT,VAIN,DGMPOA,DGDXPOA,XX,ID,DGCR,DGZP,DGSB,M3,PTR,TYPE,DGMV,DGMV0,DGNTARR,DGPMY,DGRM,DGSPACE2,DGDS,DGIDTS
+6 KILL DGPTF,DGDAT,DGPOA,DGPTDAT,DISDATE,DGZPRF,DGPTTMP,DGTMP,ICDDA,ICDPOA,ICDTMP,ICDIEN,ICDX,ICD10ORT,ICD10NIORT,ICD10ORNIT,ICD10SDT,ICDEDT,ICDLABEL,ICDCSYS,ICDRG,VA,VAEL,STR,EFFDATE,IMPDATE,VACNT
+7 QUIT
+8 ;
ELIG ; shows eligibility and disabilities
+1 DO ELIG^VADPT
WRITE #,!,"Eligibility: "_$PIECE(VAEL(1),"^",2)_$SELECT(+VAEL(3):" SC%: "_$PIECE(VAEL(3),"^",2),1:"")
+2 WRITE !,"Disabilities: "
FOR I=0:0
SET I=$ORDER(^DPT(DFN,.372,I))
if 'I
QUIT
SET I1=$SELECT($DATA(^DPT(DFN,.372,I,0)):^(0),1:"")
if +I1
Begin DoDot:1
+3 SET PSDIS=$SELECT($PIECE($GET(^DIC(31,+I1,0)),"^")]""&($PIECE($GET(^(0)),"^",4)']""):$PIECE(^(0),"^"),$PIECE($GET(^DIC(31,+I1,0)),"^",4)]"":$PIECE(^(0),"^",4),1:"")
SET PSCNT=$PIECE(I1,"^",2)
+4 if $LENGTH(PSDIS_"-"_PSCNT_"% ("_$SELECT($PIECE(I1,"^",3)
WRITE !,?15
+5 WRITE $SELECT($GET(PSDIS)]"":PSDIS_"-",1:"")_PSCNT_"% ("_$SELECT($PIECE(I1,"^",3):"SC",1:"NSC")_"), "
+6 IF $Y>22
WRITE !,"PRESS RETURN TO CONTINUE:"
READ X:DTIME
WRITE #
End DoDot:1
+7 QUIT
DATE ;EDIT CPT DATE/TIME TO BE AFTER ADMISSION DATE BUT BEFORE DISCHARGE
+1 ; DG*5.3*1057
NEW DGADM,DGIDS,I
+2 ; admission date DG*5.3*1057
SET DGADM=$PIECE(^DGPT(DA(1),0),U,2)
+3 ; initial date of service DG*5.3*1057
SET DGIDS=$PIECE(^DGPT(DA(1),0),U,14)
+4 ; DG*5.3*1057
IF DGIDS>0
IF X<DGIDS
WRITE !,"Must be on or after initial date of service",!
KILL X
QUIT
+5 ; DG*5.3*1057
IF DGIDS'>0
IF X<$$FMADD^XLFDT(DGADM,,-72)
WRITE !,"Must be at most 72 hrs prior to admission"
KILL X
QUIT
+6 IF $GET(^(70))
IF X>^(70)
WRITE !,"Not after discharge"
KILL X
QUIT
+7 SET I=0
FOR
SET I=$ORDER(^DGPT(DA(1),"C",I))
if I'>0
QUIT
IF X=+^(I,0)
WRITE !,"Cannot change to existing CPT date/time entry"
KILL X
QUIT
+8 QUIT
SETABX ;SET AB CROSSREFERENCE IN FILE 45
+1 if $PIECE($GET(^DGPT(DA(1),"C",DA,0)),U,7)
GOTO KILLABX
+2 NEW BOOL
SET (DGCPT,BOOL)=0
+3 FOR
SET DGCPT=$ORDER(^DGCPT(46,"C",DA(1),DGCPT))
if 'DGCPT
QUIT
Begin DoDot:1
+4 SET BOOL='$GET(^DGCPT(46,DGCPT,9))
End DoDot:1
if BOOL
QUIT
+5 IF 'BOOL
KILL ^DGPT("AB",$EXTRACT(X,1,30),DA(1),DA)
+6 SET ^DGPT("AB",$EXTRACT(X,1,30),DA(1),DA)=""
QUIT
KILLABX ;KILL AB CROSSREFERENCE IN FILE 45
+1 if '$PIECE($GET(^DGPT(DA(1),"C",DA,0)),U,7)
GOTO SETABX
+2 KILL ^DGPT("AB",$EXTRACT(X,1,30),DA(1),DA)
QUIT
DISP FOR I=1:1:$PIECE(DGZPRF,U,3)
Begin DoDot:1
+1 SET Y=+DGZPRF(I)
DO D^DGPTUTL
WRITE !,I,?5,Y
End DoDot:1
+2 QUIT
HELP WRITE !,"Enter '^' to stop display and edit of data,"
+1 WRITE !,"'^N' to jump to screen #N (appears in upper right of screen as"
+2 WRITE " <N>),",!,"a number to jump to that number 801 screen,"
+3 WRITE " ?? to list the 801 screens,"
+4 WRITE !,"<RET> to continue on to next screen or A-B to edit:"
+5 WRITE !?10,"A-Professional service information",!,?10,"B-Procedure codes",!,"You may also enter any combination of the above, separated by commas (ex:A,B)",!
QUIT
CPT ;DISPLAY CPT CODES AND MODIFIERS
+1 SET CPT=+DGZPRF(J,K)
SET N=$$CPT^ICPTCOD(CPT,$$GETDATE^ICDGTDRG(PTF))
SET N=$SELECT(N>0:$PIECE(N,U,2,99),1:"")
+2 WRITE $PIECE(N,U)," ",$PIECE(N,U,2)
+3 FOR I=1,2
SET MOD=$PIECE(DGZPRF(J,K),U,I+1)
if MOD
DO MOD
+4 WRITE !,?7,"Quantity: ",$PIECE(DGZPRF(J,K),U,14)
KILL I,MOD,N
QUIT
MOD SET N=$$MOD^ICPTMOD(MOD,"I",$$GETDATE^ICDGTDRG(PTF))
WRITE !,?7,"CPT Modifier ",I,":",$PIECE(N,U,2)," ",$PIECE(N,U,3)
+1 QUIT
+2 ;
DTIDS ; date check against admission and discharge dates, called from input transform on field 45/14 DG*5.3*1057
+1 NEW DGADMDT,DGDSCDT
+2 SET DGADMDT=$PIECE(^DGPT(DA,0),U,2)
SET DGDSCDT=$PIECE($GET(^DGPT(DA,70)),U)
+3 IF DGDSCDT'>0
SET DGDSCDT=9999999
+4 IF X<$$FMADD^XLFDT(DGADMDT,,-72)
WRITE !,"Must be at most 72 hrs prior to admission"
KILL X
QUIT
+5 IF X>DGDSCDT
WRITE !,"Not after discharge"
KILL X
+6 QUIT
+7 ;
DT401 ; date check against admission and discharge dates, called from input transform on field 45.01/.01 DG*5.3*1057
+1 NEW DGADMDT,DGIDS,DGDSCDT
+2 SET DGADMDT=$PIECE(^DGPT(DA(1),0),U,2)
SET DGDSCDT=$PIECE($GET(^DGPT(DA(1),70)),U)
+3 ; initial date of service
SET DGIDS=$PIECE(^DGPT(DA(1),0),U,14)
+4 IF DGDSCDT'>0
SET DGDSCDT=9999999
+5 IF DGIDS>0
IF X<DGIDS
WRITE !,"Must be on or after initial date of service",!
KILL X
QUIT
+6 IF DGIDS'>0
IF X<$$FMADD^XLFDT(DGADMDT,,-72)
WRITE !,"Must be at most 72 hrs prior to admission"
KILL X
QUIT
+7 IF X>DGDSCDT
WRITE !,"Not after discharge"
KILL X
+8 QUIT
