PSGPLXR ;BIR/MLM-EXECUTE PICK LIST XREFS ;28 FEB 96 / 2:45 PM
;;5.0; INPATIENT MEDICATIONS ;**5,126**;16 DEC 97
;
EN535(S1,ACT,XREF,FIELD,OLDV) ; Update "AC","AU" x-ref for 53.5 (PICK LIST FILE)
S S2=0 D SETVAR F S S2=$O(^PS(53.5,S1,1,S2)) Q:'S2 D EN5351(S1,S2,ACT,XREF,FIELD,OLDV)
Q
;
EN5351(S1,S2,ACT,XREF,FIELD,OLDV) ; Update "AC","AU" x-refs for 53.51 (PATIENT MULTIPLE)
N AT,PDD,ND,ON,PD,PL,PT,RB,ST,UP,UP1,WD,X D SETVAR S S3=$O(^PS(53.5,S1,1,S2,1,0))
D SET
Q:$S('PL:1,AT="":1,WD="":1,RB="":1,PT="":1,1:0)
K:$D(^PS(53.5,XREF,PL,AT,WD,RB,PT,"NO ORDERS")) ^("NO ORDERS")
I ACT="S",(XREF="AC"!UP1) S ^PS(53.5,XREF,PL,AT,WD,RB,PT,"NO ORDERS")="" Q:'S3
S S3=0 F S S3=$O(^PS(53.5,S1,1,S2,1,S3)) Q:'S3 D EN5352(S1,S2,S3,ACT,XREF,FIELD,OLDV)
Q
;
EN5352(S1,S2,S3,ACT,XREF,FIELD,OLDV) ; Update x-refs for 53.52 (ORDER MULTIPLE)
N AT,PDD,ND,ON,PD,PL,PT,RB,ST,UP,UP1,WD,X D SETVAR
S S4=0,S4=$O(^PS(53.5,S1,1,S2,1,S3,1,S4)) I S4="" D Q
.D SET
.Q:$S('PL:1,AT="":1,WD="":1,PT="":1,ST="":1,PD="":1,1:0)
.K:$D(^PS(53.5,XREF,PL,AT,WD,RB,PT,"NO ORDERS")) ^("NO ORDERS")
.K:$D(^PS(53.5,XREF,PL,AT,WD,RB,PT,ST,PD,"NO DISPENSE DRUG")) ^("NO DISPENSE DRUG")
.I ACT="S",(XREF="AC"!UP) S ^PS(53.5,XREF,PL,AT,WD,RB,PT,ST,PD,"NO DISPENSE DRUG")="" Q
.I XREF="AC"!'UP K:$D(^PS(53.5,XREF,PL,AT,WD,RB,PT,ST,PD)) ^(PD)
S S4=0 F S S4=$O(^PS(53.5,S1,1,S2,1,S3,1,S4)) Q:'S4 D EN5353(S1,S2,S3,S4,ACT,XREF,FIELD,OLDV)
Q
;
EN5353(S1,S2,S3,S4,ACT,XREF,FIELD,OLDV) ; Update x-refs for 53.53 (DISPENSE DRUG MULTIPLE)
N AT,PDD,ND,ON,PD,PL,PT,RB,ST,UP,UP1,WD,X D SETVAR
D SET
Q:$S('PL:1,AT="":1,WD="":1,PT="":1,ST="":1,PD="":1,PDD="":1,1:0)
K:$D(^PS(53.5,XREF,PL,AT,WD,RB,PT,"NO ORDERS")) ^("NO ORDERS")
I $D(^PS(53.5,XREF,PL,AT,WD,RB,PT,ST,PD,"NO DISPENSE DRUG")) K ^("NO DISPENSE DRUG")
I ACT="S",(XREF="AC"!UP) S ^PS(53.5,XREF,PL,AT,WD,RB,PT,ST,PD,PDD)="" Q
I XREF="AC"!'UP K:$D(^PS(53.5,XREF,PL,AT,WD,RB,PT,ST,PD,PDD)) ^(PDD)
Q
;
SET ; Gather data needed to update "AC","AU" xref
S ND=$G(^PS(53.5,+S1,0)),X=$G(^PS(53.5,S1,1,+S2,0)),PL=+ND
S AT=$S($L($P(X,U,2)):$P(X,U,2),1:"zz"),WD=$S($P(ND,U,7):"zns",1:$P(X,U,3)),UP1=$P(X,U,5)
S X=$P($G(^PS(53.5,S1,1,S2,0)),U,4) I X]"",$P(ND,U,6),X'="zz" S X=$S($P(X,"-",2)?1N:0,1:"")_$P(X,"-",2)_"-"_$P(X,"-")
S RB=$S($P(ND,U,8):"zz",X="":"zz",1:X),PT=$E($P($G(^DPT(S2,0)),U),1,12)_U_S2
G:'$G(S3) SET2
S X=$G(^PS(53.5,S1,1,S2,1,S3,0)),ON=+X,ST=$P(X,U,2),UP=$P(X,U,5),X=$P(X,U,6),PD="" I X S PD=$E($P($G(^PS(50.7,X,0)),U),1,7)_U_S3
G:'$G(S4) SET2
S X=$G(^PS(53.5,S1,1,S2,1,S3,1,S4,0)),X=+$G(^PS(55,S2,5,ON,1,+X,0)),PDD=$E($P($G(^PSDRUG(+X,0)),U),1,7)_U_S4
SET2 ; if this is a "kill", see if a field and old value was passed in
Q:(XREF'="AC")!(ACT'="K")!(FIELD="")!(OLDV="") Q:(@FIELD="zz")!(@FIELD="zns")
S @FIELD=OLDV
Q
SETVAR ;
S FIELD=$G(FIELD),OLDV=$G(OLDV)
Q
;
ENABO(S1,XREF,ACT) ;Set AB/AO xref for Pick List, Ward Group, & Start date.
N X S X=$G(^PS(53.5,S1,0))
I ACT="S" D Q
.I (XREF="AB")&('$P(X,"^",5)) S ^PS(53.5,XREF,+$P(X,U,2),+$P(X,U,3),S1)="" Q
.I (XREF="AO")&($P(X,"^",5)=2) S ^PS(53.5,XREF,+$P(X,U,2),+$P(X,U,3),S1)=""
K ^PS(53.5,XREF,+$P(X,U,2),+$P(X,U,3),S1)
Q
ENA(S1,ACT) ; Set A xref for Pick List # and Ward Group.
N X S X=$G(^PS(53.5,S1,0))
Q:X=""
I ACT="S" S ^PS(53.5,"A",$P(X,U,2),S1)="" Q
K ^PS(53.5,"A",$P(X,U,2),S1)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGPLXR 3388 printed Sep 23, 2025@19:39:06 Page 2
PSGPLXR ;BIR/MLM-EXECUTE PICK LIST XREFS ;28 FEB 96 / 2:45 PM
+1 ;;5.0; INPATIENT MEDICATIONS ;**5,126**;16 DEC 97
+2 ;
EN535(S1,ACT,XREF,FIELD,OLDV) ; Update "AC","AU" x-ref for 53.5 (PICK LIST FILE)
+1 SET S2=0
DO SETVAR
FOR
SET S2=$ORDER(^PS(53.5,S1,1,S2))
if 'S2
QUIT
DO EN5351(S1,S2,ACT,XREF,FIELD,OLDV)
+2 QUIT
+3 ;
EN5351(S1,S2,ACT,XREF,FIELD,OLDV) ; Update "AC","AU" x-refs for 53.51 (PATIENT MULTIPLE)
+1 NEW AT,PDD,ND,ON,PD,PL,PT,RB,ST,UP,UP1,WD,X
DO SETVAR
SET S3=$ORDER(^PS(53.5,S1,1,S2,1,0))
+2 DO SET
+3 if $SELECT('PL
QUIT
+4 if $DATA(^PS(53.5,XREF,PL,AT,WD,RB,PT,"NO ORDERS"))
KILL ^("NO ORDERS")
+5 IF ACT="S"
IF (XREF="AC"!UP1)
SET ^PS(53.5,XREF,PL,AT,WD,RB,PT,"NO ORDERS")=""
if 'S3
QUIT
+6 SET S3=0
FOR
SET S3=$ORDER(^PS(53.5,S1,1,S2,1,S3))
if 'S3
QUIT
DO EN5352(S1,S2,S3,ACT,XREF,FIELD,OLDV)
+7 QUIT
+8 ;
EN5352(S1,S2,S3,ACT,XREF,FIELD,OLDV) ; Update x-refs for 53.52 (ORDER MULTIPLE)
+1 NEW AT,PDD,ND,ON,PD,PL,PT,RB,ST,UP,UP1,WD,X
DO SETVAR
+2 SET S4=0
SET S4=$ORDER(^PS(53.5,S1,1,S2,1,S3,1,S4))
IF S4=""
Begin DoDot:1
+3 DO SET
+4 if $SELECT('PL
QUIT
+5 if $DATA(^PS(53.5,XREF,PL,AT,WD,RB,PT,"NO ORDERS"))
KILL ^("NO ORDERS")
+6 if $DATA(^PS(53.5,XREF,PL,AT,WD,RB,PT,ST,PD,"NO DISPENSE DRUG"))
KILL ^("NO DISPENSE DRUG")
+7 IF ACT="S"
IF (XREF="AC"!UP)
SET ^PS(53.5,XREF,PL,AT,WD,RB,PT,ST,PD,"NO DISPENSE DRUG")=""
QUIT
+8 IF XREF="AC"!'UP
if $DATA(^PS(53.5,XREF,PL,AT,WD,RB,PT,ST,PD))
KILL ^(PD)
End DoDot:1
QUIT
+9 SET S4=0
FOR
SET S4=$ORDER(^PS(53.5,S1,1,S2,1,S3,1,S4))
if 'S4
QUIT
DO EN5353(S1,S2,S3,S4,ACT,XREF,FIELD,OLDV)
+10 QUIT
+11 ;
EN5353(S1,S2,S3,S4,ACT,XREF,FIELD,OLDV) ; Update x-refs for 53.53 (DISPENSE DRUG MULTIPLE)
+1 NEW AT,PDD,ND,ON,PD,PL,PT,RB,ST,UP,UP1,WD,X
DO SETVAR
+2 DO SET
+3 if $SELECT('PL
QUIT
+4 if $DATA(^PS(53.5,XREF,PL,AT,WD,RB,PT,"NO ORDERS"))
KILL ^("NO ORDERS")
+5 IF $DATA(^PS(53.5,XREF,PL,AT,WD,RB,PT,ST,PD,"NO DISPENSE DRUG"))
KILL ^("NO DISPENSE DRUG")
+6 IF ACT="S"
IF (XREF="AC"!UP)
SET ^PS(53.5,XREF,PL,AT,WD,RB,PT,ST,PD,PDD)=""
QUIT
+7 IF XREF="AC"!'UP
if $DATA(^PS(53.5,XREF,PL,AT,WD,RB,PT,ST,PD,PDD))
KILL ^(PDD)
+8 QUIT
+9 ;
SET ; Gather data needed to update "AC","AU" xref
+1 SET ND=$GET(^PS(53.5,+S1,0))
SET X=$GET(^PS(53.5,S1,1,+S2,0))
SET PL=+ND
+2 SET AT=$SELECT($LENGTH($PIECE(X,U,2)):$PIECE(X,U,2),1:"zz")
SET WD=$SELECT($PIECE(ND,U,7):"zns",1:$PIECE(X,U,3))
SET UP1=$PIECE(X,U,5)
+3 SET X=$PIECE($GET(^PS(53.5,S1,1,S2,0)),U,4)
IF X]""
IF $PIECE(ND,U,6)
IF X'="zz"
SET X=$SELECT($PIECE(X,"-",2)?1N:0,1:"")_$PIECE(X,"-",2)_"-"_$PIECE(X,"-")
+4 SET RB=$SELECT($PIECE(ND,U,8):"zz",X="":"zz",1:X)
SET PT=$EXTRACT($PIECE($GET(^DPT(S2,0)),U),1,12)_U_S2
+5 if '$GET(S3)
GOTO SET2
+6 SET X=$GET(^PS(53.5,S1,1,S2,1,S3,0))
SET ON=+X
SET ST=$PIECE(X,U,2)
SET UP=$PIECE(X,U,5)
SET X=$PIECE(X,U,6)
SET PD=""
IF X
SET PD=$EXTRACT($PIECE($GET(^PS(50.7,X,0)),U),1,7)_U_S3
+7 if '$GET(S4)
GOTO SET2
+8 SET X=$GET(^PS(53.5,S1,1,S2,1,S3,1,S4,0))
SET X=+$GET(^PS(55,S2,5,ON,1,+X,0))
SET PDD=$EXTRACT($PIECE($GET(^PSDRUG(+X,0)),U),1,7)_U_S4
SET2 ; if this is a "kill", see if a field and old value was passed in
+1 if (XREF'="AC")!(ACT'="K")!(FIELD="")!(OLDV="")
QUIT
if (@FIELD="zz")!(@FIELD="zns")
QUIT
+2 SET @FIELD=OLDV
+3 QUIT
SETVAR ;
+1 SET FIELD=$GET(FIELD)
SET OLDV=$GET(OLDV)
+2 QUIT
+3 ;
ENABO(S1,XREF,ACT) ;Set AB/AO xref for Pick List, Ward Group, & Start date.
+1 NEW X
SET X=$GET(^PS(53.5,S1,0))
+2 IF ACT="S"
Begin DoDot:1
+3 IF (XREF="AB")&('$PIECE(X,"^",5))
SET ^PS(53.5,XREF,+$PIECE(X,U,2),+$PIECE(X,U,3),S1)=""
QUIT
+4 IF (XREF="AO")&($PIECE(X,"^",5)=2)
SET ^PS(53.5,XREF,+$PIECE(X,U,2),+$PIECE(X,U,3),S1)=""
End DoDot:1
QUIT
+5 KILL ^PS(53.5,XREF,+$PIECE(X,U,2),+$PIECE(X,U,3),S1)
+6 QUIT
ENA(S1,ACT) ; Set A xref for Pick List # and Ward Group.
+1 NEW X
SET X=$GET(^PS(53.5,S1,0))
+2 if X=""
QUIT
+3 IF ACT="S"
SET ^PS(53.5,"A",$PIECE(X,U,2),S1)=""
QUIT
+4 KILL ^PS(53.5,"A",$PIECE(X,U,2),S1)
+5 QUIT
