DGPTSC01 ;ALB/MTC - Additional routines to check for valid jumping ; JUN 14,1991
;;5.3;Registration;;Aug 13, 1993
;;MAS 5.1;
501 ;-- check if jump to expanded question was valid.
S DGTX=X,DGER=1
N DGPTIT,DGBPC,DGHOLD,DGPTF,DG701
S DGHOLD=^DGPT(DA(1),"M",DA,0),DGPTF=DA(1)
F DGI=5:1:9 I $P(DGHOLD,U,DGI)]"" S DGPTIT($P(DGHOLD,U,DGI)_";ICD9(")=""
D SCAN^DGPTSCAN
I $D(DGBPC(DGFLAG)) K:(DGFLAG=4)&($$ACTIVE(DGPTF,DGTX)) DGTX S:$D(DGTX) DGER=0,X=DGTX G ENQ
D ERRMSG S DGER=1
G ENQ
;
401 ;-- check if jump to expanded question was valid.
S DGTX=X
N DGPTIT,DGBPC,DGHOLD,DGPTF,DG701
S DGHOLD=^DGPT(DA(1),"S",DA,0)
F DGI=8:1:12 I $P(DGHOLD,U,DGI)]"" S DGPTIT($P(DGHOLD,U,DGI)_";ICD0(")=""
D SCAN^DGPTSCAN
I $D(DGBPC(DGFLAG)) S DGER=0,X=DGTX G ENQ
D ERRMSG S DGER=1
G ENQ
;
701 ;--
N DGREC,DGPTF,DGPTIT,DGBPC,DGHOLD,DG701
S DGPTF=DA,DGTX=X
G ENQ:'$D(^DGPT(DA,70)) S DGREC=^(70)
F DGI=10,16:1:24 I $P(DGREC,U,DGI) S DGPTIT($P(DGREC,U,DGI)_";ICD9(")=""
D SCAN^DGPTSCAN
D FLAGCHK^DGPTSCAN,GETNUM^DGPTSCAN
F DGI=2:1:DGFNUM I $P(DG701,U,DGI)]"",$D(DGBPC(DGI)) K DGBPC(DGI)
S DGER=1
F DGI=2:1:DGFNUM I ($D(DGBPC(DGI))&(DGFLAG=DGI)) K:(DGFLAG=4)&($$ACTIVE(DGPTF,DGTX)) DGTX S DGER=0 S:$D(DGTX) X=DGTX Q
I 'DGER S:'$D(DGTX) DGER=1 G ENQ
D ERRMSG G ENQ
ERRMSG ;-- generic error message
W !,"*** ERROR *** You must select a ICD that requires an expanded response."
Q
;
ENQ ;
K DGI,DGTX,DGHOLD,DGPTIT,DGBPC,DGPTF,DG701
Q
;
DRUG ;-- if default drug is present in 45.89 then use it
;-- pass in DGPTIT(X) for one ICD9 code.
S DGTY=$O(DGPTIT(0))
G:'DGTY DRUGQ
K DGTX
I $D(^DIC(45.89,"ASPL",DGTY)) F DGTI=0:0 S DGTI=$O(^DIC(45.89,"ASPL",DGTY,DGTI)) Q:DGTI']"" I $D(^DIC(45.89,DGTI,0)),$P(^(0),U)=4,$D(^DIC(45.61,+$P(^(0),U,4),0)) S DGTX=$P(^(0),U)
;
DRUGQ ;
K DGTY,DGTI
Q
;
ACTIVE(PTF,DRUG) ;-- check if drug has been inactivated
;-- returns 1 if not active, else 0
N DATE,SUBDATE,ACTIVE
S ACTIVE=0
S DATE=$S('$D(^DGPT(PTF,70)):DT,^(70):+^(70),1:DT),SUBDATE=$S($D(^DIC(45.61,+DRUG,0)):$P(^(0),U,3),1:"")
I SUBDATE>0,SUBDATE<DATE S Y=SUBDATE X ^DD("DD") W !,"*** ERROR *** This Substance has been inactivated as of ",Y S ACTIVE=1
Q ACTIVE
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTSC01 2227 printed Sep 23, 2025@20:29:28 Page 2
DGPTSC01 ;ALB/MTC - Additional routines to check for valid jumping ; JUN 14,1991
+1 ;;5.3;Registration;;Aug 13, 1993
+2 ;;MAS 5.1;
501 ;-- check if jump to expanded question was valid.
+1 SET DGTX=X
SET DGER=1
+2 NEW DGPTIT,DGBPC,DGHOLD,DGPTF,DG701
+3 SET DGHOLD=^DGPT(DA(1),"M",DA,0)
SET DGPTF=DA(1)
+4 FOR DGI=5:1:9
IF $PIECE(DGHOLD,U,DGI)]""
SET DGPTIT($PIECE(DGHOLD,U,DGI)_";ICD9(")=""
+5 DO SCAN^DGPTSCAN
+6 IF $DATA(DGBPC(DGFLAG))
if (DGFLAG=4)&($$ACTIVE(DGPTF,DGTX))
KILL DGTX
if $DATA(DGTX)
SET DGER=0
SET X=DGTX
GOTO ENQ
+7 DO ERRMSG
SET DGER=1
+8 GOTO ENQ
+9 ;
401 ;-- check if jump to expanded question was valid.
+1 SET DGTX=X
+2 NEW DGPTIT,DGBPC,DGHOLD,DGPTF,DG701
+3 SET DGHOLD=^DGPT(DA(1),"S",DA,0)
+4 FOR DGI=8:1:12
IF $PIECE(DGHOLD,U,DGI)]""
SET DGPTIT($PIECE(DGHOLD,U,DGI)_";ICD0(")=""
+5 DO SCAN^DGPTSCAN
+6 IF $DATA(DGBPC(DGFLAG))
SET DGER=0
SET X=DGTX
GOTO ENQ
+7 DO ERRMSG
SET DGER=1
+8 GOTO ENQ
+9 ;
701 ;--
+1 NEW DGREC,DGPTF,DGPTIT,DGBPC,DGHOLD,DG701
+2 SET DGPTF=DA
SET DGTX=X
+3 if '$DATA(^DGPT(DA,70))
GOTO ENQ
SET DGREC=^(70)
+4 FOR DGI=10,16:1:24
IF $PIECE(DGREC,U,DGI)
SET DGPTIT($PIECE(DGREC,U,DGI)_";ICD9(")=""
+5 DO SCAN^DGPTSCAN
+6 DO FLAGCHK^DGPTSCAN
DO GETNUM^DGPTSCAN
+7 FOR DGI=2:1:DGFNUM
IF $PIECE(DG701,U,DGI)]""
IF $DATA(DGBPC(DGI))
KILL DGBPC(DGI)
+8 SET DGER=1
+9 FOR DGI=2:1:DGFNUM
IF ($DATA(DGBPC(DGI))&(DGFLAG=DGI))
if (DGFLAG=4)&($$ACTIVE(DGPTF,DGTX))
KILL DGTX
SET DGER=0
if $DATA(DGTX)
SET X=DGTX
QUIT
+10 IF 'DGER
if '$DATA(DGTX)
SET DGER=1
GOTO ENQ
+11 DO ERRMSG
GOTO ENQ
ERRMSG ;-- generic error message
+1 WRITE !,"*** ERROR *** You must select a ICD that requires an expanded response."
+2 QUIT
+3 ;
ENQ ;
+1 KILL DGI,DGTX,DGHOLD,DGPTIT,DGBPC,DGPTF,DG701
+2 QUIT
+3 ;
DRUG ;-- if default drug is present in 45.89 then use it
+1 ;-- pass in DGPTIT(X) for one ICD9 code.
+2 SET DGTY=$ORDER(DGPTIT(0))
+3 if 'DGTY
GOTO DRUGQ
+4 KILL DGTX
+5 IF $DATA(^DIC(45.89,"ASPL",DGTY))
FOR DGTI=0:0
SET DGTI=$ORDER(^DIC(45.89,"ASPL",DGTY,DGTI))
if DGTI']""
QUIT
IF $DATA(^DIC(45.89,DGTI,0))
IF $PIECE(^(0),U)=4
IF $DATA(^DIC(45.61,+$PIECE(^(0),U,4),0))
SET DGTX=$PIECE(^(0),U)
+6 ;
DRUGQ ;
+1 KILL DGTY,DGTI
+2 QUIT
+3 ;
ACTIVE(PTF,DRUG) ;-- check if drug has been inactivated
+1 ;-- returns 1 if not active, else 0
+2 NEW DATE,SUBDATE,ACTIVE
+3 SET ACTIVE=0
+4 SET DATE=$SELECT('$DATA(^DGPT(PTF,70)):DT,^(70):+^(70),1:DT)
SET SUBDATE=$SELECT($DATA(^DIC(45.61,+DRUG,0)):$PIECE(^(0),U,3),1:"")
+5 IF SUBDATE>0
IF SUBDATE<DATE
SET Y=SUBDATE
XECUTE ^DD("DD")
WRITE !,"*** ERROR *** This Substance has been inactivated as of ",Y
SET ACTIVE=1
+6 QUIT ACTIVE
