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