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 Sep 23, 2025@19:37:56 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)
