- 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
- 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
