- PSGOE2 ;BIR/MV-CHECK INACTIVE DRUG ; 23 Sep 98 / 8:38 AM
- ;;5.0; INPATIENT MEDICATIONS ;**7,19,62**;16 DEC 97
- ;
- ; Reference to ^PS(50.7 is supported by DBIA# 2180
- ; Reference to ^PSDRUG( is supported by DBIA# 2192
- ;
- CHKDRG ;*** Check inactive Orderable Item/disp drug and also if marked for UD
- N DRG,DRGPT,INACTDT,X K PSGPFLG,PSGDFLG,PSGDI
- ;S:'$G(PSGDI) PSGDI=$G(PSGPD)
- S PSGDFLG='$$DDOK("^PS(55,"_PSGP_",5,"_+PSGORD_",1,",PSGPD)
- ;S X=$P($G(^PS(50.7,PSGDI,0)),"^",4) I X,(X'>DT) S (PSGR,PSGE)="",PSGPFLG=1 Q
- I '$$OIOK(PSGPD) S (PSGR,PSGE)="",PSGPFLG=1 Q
- Q
- CHKDD(F) ;*** Check inactive dispense drug within the order.
- ;* 9/20/94
- ;* When check for a valid dispense drug, the following logic is used:
- ;* If ^PS(55 does not have a valid ddrug, PSGDFLG=1
- ;* If ddrug in ^PS(55, has an inactive date, don't check ^PSDRUG
- ;* If a ddrug in ^PS(55 pointed to an invalid ^PSDRUG note, PSGDFLG=1.
- ;* The existing ddrugs in ^PS(55 will not copy to the new order.
- ;* Only store the new selected ddrug in the new order.
- ;* All active ddrugs in ^PS(55 has to be checked for valid ^PSDRUG
- ;* If ddrugs in ^PS(55 are all inactive, PSGINDT=0
- ;* If this routine returns 1, it means either no valid ddrug in the
- ;* drug file or all the ddrug in ^PS(55 are inactive
- ;*
- N DRG,DRGPT,PSGDFLG,PSGINDT
- S PSGDFLG=0,PSGINDT=1 I '$O(@(F_"1,"_0_")")) Q 1
- F DRG=0:0 S DRG=$O(@(F_"1,"_DRG_")")) Q:'DRG S DRGPT=^(DRG,0),INACTDT=+$P(DRGPT,U,3) I $S('INACTDT:1,1:INACTDT>DT) S PSGINDT=0 D Q:PSGDFLG
- . I $P(^PSDRUG(+DRGPT,2),U,3)'["U"!($S('+$G(^PSDRUG(+DRGPT,"I")):0,^("I")'>DT:1,1:0)) S PSGDFLG=1
- Q $S(PSGDFLG:1,1:PSGINDT)
- STUFFDD() ;*** Stuff DD in ^PS(53.1 only if a valid DD is 1 to 1 link to OI.
- ;*** Stuff DD in if only one valid DD is marked for UD.
- ;*** Do not stuff if there are multiple DD tie to a Orderable Item.
- ;*** Do not stuff if mult. DD marked as UD item & only 1 is a valid DD
- I '$D(PSGDT) D NOW^%DTC S PSGDT=$E(%,1,12)
- N Q,X,DRG,QPT S (X,Q,QPT)=0
- I '$O(^PS(53.1,+PSGORD,1,0)) F DRG=0:0 S DRG=$O(^PSDRUG("ASP",+$G(^PS(53.1,+PSGORD,.2)),DRG)) Q:'DRG S:$G(^PSDRUG(DRG,"I")) X=^("I")'>PSGDT I $P(^PSDRUG(DRG,2),U,3)["U" S Q=Q+1 S:'X QPT=DRG
- Q $S(Q=1:QPT,1:0)
- CHK ; check for valid reply and questions
- S C=1 I PSGOEA="P"!(PSGOEA="S") W $S(PSGOEA="P":"RINT",1:"HOW") Q
- I PSGOEA="C",PSJPCAF,'PSGOENG,'$D(PSGODF),'PSGDI,'PSGPI,'$G(PSGPFLG) W "OPY" Q
- I PSGOEA="DC",PSGACT["D" W " (DISCONTINUE)" S PSGOEA="D" Q
- I $L(PSGOEA)=1,PSGOEA'["?",PSGACT[PSGOEA W $S(PSGOEA="R"&PSGRRF:"EINSTATE",1:$P("^YPASS^ISCONTINUE^DIT^INISH^OLD^NCOMPLETE^OG DISPLAY^ENEW^ERIFY","^",$F("BDEFHILRV",PSGOEA))) Q
- S C=0 I PSGOEA'?1."?" W $C(7)," ??" Q
- ;
- DDOK(PSJF,OI) ;Check to be sure all dispense drugs that are active in the
- ;order are valid.
- ; Input: PSJF - File root of the order including all but the IEN of
- ; the drug. (EX "^PS(53.45,X,2,")
- ; OI - IEN of the order's orderable item
- ; Output: 1 - all active DD's in the order are valid
- ; 0 - no DD's active DD's or at least one active is invalid
- N DDCNT,ND,PSJ,X S (X,DDCNT)=0
- I $P(PSJSYSU,";")'=3,('$O(@(PSJF_"0)"))) Q 1
- F PSJ=0:0 S PSJ=$O(@(PSJF_PSJ_")")) Q:'PSJ!X S ND=$G(@(PSJF_PSJ_",0)")) D
- .I $P(ND,U,3),($P(ND,U,3)'>PSGDT) Q
- .S DDCNT=DDCNT+1
- .S X=$S('$D(^PSDRUG(+ND,0)):1,$P($G(^(2)),U,3)'["U":1,+$G(^(2))'=+OI:1,$G(^("I"))="":0,1:^("I")'>PSGDT)
- Q $S('DDCNT:0,X=1:0,1:1)
- ;
- OIOK(X) ; Check to be sure orderable item is valid
- ; input: X - IEN of orderable item
- ; Output: 0 - invalid
- ; 1 - valid
- Q:'$D(^PS(50.7,X,0)) 0
- S X=$P($G(^PS(50.7,X,0)),U,4)
- Q $S('X:1,X'>DT:0,1:1)
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGOE2 3666 printed Jan 18, 2025@03:03:04 Page 2
- PSGOE2 ;BIR/MV-CHECK INACTIVE DRUG ; 23 Sep 98 / 8:38 AM
- +1 ;;5.0; INPATIENT MEDICATIONS ;**7,19,62**;16 DEC 97
- +2 ;
- +3 ; Reference to ^PS(50.7 is supported by DBIA# 2180
- +4 ; Reference to ^PSDRUG( is supported by DBIA# 2192
- +5 ;
- CHKDRG ;*** Check inactive Orderable Item/disp drug and also if marked for UD
- +1 NEW DRG,DRGPT,INACTDT,X
- KILL PSGPFLG,PSGDFLG,PSGDI
- +2 ;S:'$G(PSGDI) PSGDI=$G(PSGPD)
- +3 SET PSGDFLG='$$DDOK("^PS(55,"_PSGP_",5,"_+PSGORD_",1,",PSGPD)
- +4 ;S X=$P($G(^PS(50.7,PSGDI,0)),"^",4) I X,(X'>DT) S (PSGR,PSGE)="",PSGPFLG=1 Q
- +5 IF '$$OIOK(PSGPD)
- SET (PSGR,PSGE)=""
- SET PSGPFLG=1
- QUIT
- +6 QUIT
- CHKDD(F) ;*** Check inactive dispense drug within the order.
- +1 ;* 9/20/94
- +2 ;* When check for a valid dispense drug, the following logic is used:
- +3 ;* If ^PS(55 does not have a valid ddrug, PSGDFLG=1
- +4 ;* If ddrug in ^PS(55, has an inactive date, don't check ^PSDRUG
- +5 ;* If a ddrug in ^PS(55 pointed to an invalid ^PSDRUG note, PSGDFLG=1.
- +6 ;* The existing ddrugs in ^PS(55 will not copy to the new order.
- +7 ;* Only store the new selected ddrug in the new order.
- +8 ;* All active ddrugs in ^PS(55 has to be checked for valid ^PSDRUG
- +9 ;* If ddrugs in ^PS(55 are all inactive, PSGINDT=0
- +10 ;* If this routine returns 1, it means either no valid ddrug in the
- +11 ;* drug file or all the ddrug in ^PS(55 are inactive
- +12 ;*
- +13 NEW DRG,DRGPT,PSGDFLG,PSGINDT
- +14 SET PSGDFLG=0
- SET PSGINDT=1
- IF '$ORDER(@(F_"1,"_0_")"))
- QUIT 1
- +15 FOR DRG=0:0
- SET DRG=$ORDER(@(F_"1,"_DRG_")"))
- if 'DRG
- QUIT
- SET DRGPT=^(DRG,0)
- SET INACTDT=+$PIECE(DRGPT,U,3)
- IF $SELECT('INACTDT:1,1:INACTDT>DT)
- SET PSGINDT=0
- Begin DoDot:1
- +16 IF $PIECE(^PSDRUG(+DRGPT,2),U,3)'["U"!($SELECT('+$GET(^PSDRUG(+DRGPT,"I")):0,^("I")'>DT:1,1:0))
- SET PSGDFLG=1
- End DoDot:1
- if PSGDFLG
- QUIT
- +17 QUIT $SELECT(PSGDFLG:1,1:PSGINDT)
- STUFFDD() ;*** Stuff DD in ^PS(53.1 only if a valid DD is 1 to 1 link to OI.
- +1 ;*** Stuff DD in if only one valid DD is marked for UD.
- +2 ;*** Do not stuff if there are multiple DD tie to a Orderable Item.
- +3 ;*** Do not stuff if mult. DD marked as UD item & only 1 is a valid DD
- +4 IF '$DATA(PSGDT)
- DO NOW^%DTC
- SET PSGDT=$EXTRACT(%,1,12)
- +5 NEW Q,X,DRG,QPT
- SET (X,Q,QPT)=0
- +6 IF '$ORDER(^PS(53.1,+PSGORD,1,0))
- FOR DRG=0:0
- SET DRG=$ORDER(^PSDRUG("ASP",+$GET(^PS(53.1,+PSGORD,.2)),DRG))
- if 'DRG
- QUIT
- if $GET(^PSDRUG(DRG,"I"))
- SET X=^("I")'>PSGDT
- IF $PIECE(^PSDRUG(DRG,2),U,3)["U"
- SET Q=Q+1
- if 'X
- SET QPT=DRG
- +7 QUIT $SELECT(Q=1:QPT,1:0)
- CHK ; check for valid reply and questions
- +1 SET C=1
- IF PSGOEA="P"!(PSGOEA="S")
- WRITE $SELECT(PSGOEA="P":"RINT",1:"HOW")
- QUIT
- +2 IF PSGOEA="C"
- IF PSJPCAF
- IF 'PSGOENG
- IF '$DATA(PSGODF)
- IF 'PSGDI
- IF 'PSGPI
- IF '$GET(PSGPFLG)
- WRITE "OPY"
- QUIT
- +3 IF PSGOEA="DC"
- IF PSGACT["D"
- WRITE " (DISCONTINUE)"
- SET PSGOEA="D"
- QUIT
- +4 IF $LENGTH(PSGOEA)=1
- IF PSGOEA'["?"
- IF PSGACT[PSGOEA
- WRITE $SELECT(PSGOEA="R"&PSGRRF:"EINSTATE",1:$PIECE("^YPASS^ISCONTINUE^DIT^INISH^OLD^NCOMPLETE^OG DISPLAY^ENEW^ERIFY","^",$FIND("BDEFHILRV",PSGOEA)))
- QUIT
- +5 SET C=0
- IF PSGOEA'?1."?"
- WRITE $CHAR(7)," ??"
- QUIT
- +6 ;
- DDOK(PSJF,OI) ;Check to be sure all dispense drugs that are active in the
- +1 ;order are valid.
- +2 ; Input: PSJF - File root of the order including all but the IEN of
- +3 ; the drug. (EX "^PS(53.45,X,2,")
- +4 ; OI - IEN of the order's orderable item
- +5 ; Output: 1 - all active DD's in the order are valid
- +6 ; 0 - no DD's active DD's or at least one active is invalid
- +7 NEW DDCNT,ND,PSJ,X
- SET (X,DDCNT)=0
- +8 IF $PIECE(PSJSYSU,";")'=3
- IF ('$ORDER(@(PSJF_"0)")))
- QUIT 1
- +9 FOR PSJ=0:0
- SET PSJ=$ORDER(@(PSJF_PSJ_")"))
- if 'PSJ!X
- QUIT
- SET ND=$GET(@(PSJF_PSJ_",0)"))
- Begin DoDot:1
- +10 IF $PIECE(ND,U,3)
- IF ($PIECE(ND,U,3)'>PSGDT)
- QUIT
- +11 SET DDCNT=DDCNT+1
- +12 SET X=$SELECT('$DATA(^PSDRUG(+ND,0)):1,$PIECE($GET(^(2)),U,3)'["U":1,+$GET(^(2))'=+OI:1,$GET(^("I"))="":0,1:^("I")'>PSGDT)
- End DoDot:1
- +13 QUIT $SELECT('DDCNT:0,X=1:0,1:1)
- +14 ;
- OIOK(X) ; Check to be sure orderable item is valid
- +1 ; input: X - IEN of orderable item
- +2 ; Output: 0 - invalid
- +3 ; 1 - valid
- +4 if '$DATA(^PS(50.7,X,0))
- QUIT 0
- +5 SET X=$PIECE($GET(^PS(50.7,X,0)),U,4)
- +6 QUIT $SELECT('X:1,X'>DT:0,1:1)