- 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 Feb 19, 2025@00:19:50 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
