PSGAXR ;BIR/CML3-EXECUTE VARIOUS XREFS ;24 JUN 96 / 12:06 PM
;;5.0;INPATIENT MEDICATIONS;**111,265**;16 DEC 97;Build 4
;
ENSS ; set x-refs under 53.1,28
S ZZ=+$G(^PS(53.1,DA,.2)),ZZZ=+$G(^PS(53.1,DA,"DSS")) S:$D(PSGP)[0 PSGP=$P($G(^PS(53.1,DA,0)),"^",15)_"^1" I 'PSGP,'ZZ K ZZ K:$P(PSGP,"^",2) PSGP Q
I PSGP D
. S ^PS(53.1,"AS",X,+PSGP,DA)="" I $S(X["A":0,1:X'["D") S ^PS(53.1,"AC",+PSGP,DA)="" S:ZZ ^PS(53.1,"AOD",+PSGP,ZZ,DA)="" S:ZZZ ^PS(53.1,"AD",ZZZ,+PSGP,DA)=""
. I X="P",+$P($G(^PS(53.1,DA,4)),U) S ^PS(53.1,"AV",+PSGP,DA)=""
;I X]"" S ZZ=$S($G(ORIFN):ORIFN,1:$P($G(^PS(53.1,DA,0)),"^",21)_"^1") I ZZ S ORIFN=+ZZ D ENSC^PSGORU K:$P(ZZ,"^",2) ORIFN
;D EN1^PSJHL2(PSGP,"OC",DA_"P")
K ZZ,ZZZ K:$P(PSGP,"^",2) PSGP Q
;
ENSK ; kill x-refs under 53.1,28
S:$D(PSGP)[0 PSGP=$P($G(^PS(53.1,DA,0)),"^",15)_"^1" S ZZ=+$G(^PS(53.1,DA,.1)),ZZZ=+$G(^PS(53.1,DA,"DSS"))
I PSGP K ^PS(53.1,"AC",+PSGP,DA),^PS(53.1,"AS",X,+PSGP,DA),^PS(53.1,"AV",+PSGP,DA) K:ZZ ^PS(53.1,"AOD",+PSGP,ZZ,DA) K:ZZZ ^PS(53.1,"AD",ZZZ,+PSGP,DA)
K ZZ,ZZZ K:$P(PSGP,"^",2) PSGP Q
;
ENNDS ; set x-refs under 53.1,.1
S ^PS(53.1,"D",X,DA)="" S:$D(PSGP)[0 PSGP=$P($G(^PS(53.1,DA,0)),"^",15)_"^1" I PSGP S PSGX=X D END^PSGSICHK S X=PSGX,PSGX=$P($G(^PS(53.1,DA,0)),"^",9) I $S(PSGX["A":0,1:PSGX'["D") S ^PS(53.1,"AOD",+PSGP,X,DA)=""
K PSGX K:$P(PSGP,"^",2) PSGP Q
;
ENNDK ; kill x-refs under 53.1,.1
S:$D(PSGP)[0 PSGP=$P($G(^PS(53.1,DA,0)),"^",15)_"^1" K ^PS(53.1,"D",X,DA) K:PSGP ^PS(53.1,"AOD",+PSGP,X,DA) K:$P(PSGP,"^",2) PSGP Q
;
ENNPS ; set x-refs under 53.1,.5
S ^PS(53.1,"C",X,DA)="",PSGX=$P($G(^PS(53.1,DA,0)),"^",9) S:PSGX]"" ^PS(53.1,"AS",PSGX,X,DA)=""
I $S(PSGX["A":0,1:PSGX'["D") S ^PS(53.1,"AC",X,DA)=""
I PSGX="P",+$P($G(^PS(53.1,DA,4)),U) S ^PS(53.1,"AV",X,DA)=""
S:PSGX ^PS(53.1,"AOD",X,PSGX,DA)=""
K PSGX Q
;
ENNPK ; kill x-refs under 53.1,.5
K ^PS(53.1,"AC",X,DA),^PS(53.1,"C",X,DA) S PSGX=$P($G(^PS(53.1,DA,0)),"^",9) K:PSGX]"" ^PS(53.1,"AS",PSGX,X,DA) S PSGX=+$G(^PS(53.1,DA,.1)) K:PSGX ^PS(53.1,"AOD",X,PSGX,DA)
K ^PS(53.1,"AV",X,DA)
K PSGX Q
ENNACK ; Set x-refs under Nurse verification for acknowleged pending orders.
S PSGX=$G(^PS(53.1,DA,0)) S PSGP=$P(PSGX,U,15)
S PSGST=$P(PSGX,U,9)
I PSGP,+X,(PSGST="P") S ^PS(53.1,"AV",PSGP,DA)=""
K PSGX,PSGP,PSGST Q
ENNACKK ; Kill x-refs under Nurse verification
S PSGP=$P($G(^PS(53.1,DA,0)),U,15)
K:+PSGP ^PS(53.1,"AV",+PSGP,DA) Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGAXR 2432 printed Oct 16, 2024@18:01:38 Page 2
PSGAXR ;BIR/CML3-EXECUTE VARIOUS XREFS ;24 JUN 96 / 12:06 PM
+1 ;;5.0;INPATIENT MEDICATIONS;**111,265**;16 DEC 97;Build 4
+2 ;
ENSS ; set x-refs under 53.1,28
+1 SET ZZ=+$GET(^PS(53.1,DA,.2))
SET ZZZ=+$GET(^PS(53.1,DA,"DSS"))
if $DATA(PSGP)[0
SET PSGP=$PIECE($GET(^PS(53.1,DA,0)),"^",15)_"^1"
IF 'PSGP
IF 'ZZ
KILL ZZ
if $PIECE(PSGP,"^",2)
KILL PSGP
QUIT
+2 IF PSGP
Begin DoDot:1
+3 SET ^PS(53.1,"AS",X,+PSGP,DA)=""
IF $SELECT(X["A":0,1:X'["D")
SET ^PS(53.1,"AC",+PSGP,DA)=""
if ZZ
SET ^PS(53.1,"AOD",+PSGP,ZZ,DA)=""
if ZZZ
SET ^PS(53.1,"AD",ZZZ,+PSGP,DA)=""
+4 IF X="P"
IF +$PIECE($GET(^PS(53.1,DA,4)),U)
SET ^PS(53.1,"AV",+PSGP,DA)=""
End DoDot:1
+5 ;I X]"" S ZZ=$S($G(ORIFN):ORIFN,1:$P($G(^PS(53.1,DA,0)),"^",21)_"^1") I ZZ S ORIFN=+ZZ D ENSC^PSGORU K:$P(ZZ,"^",2) ORIFN
+6 ;D EN1^PSJHL2(PSGP,"OC",DA_"P")
+7 KILL ZZ,ZZZ
if $PIECE(PSGP,"^",2)
KILL PSGP
QUIT
+8 ;
ENSK ; kill x-refs under 53.1,28
+1 if $DATA(PSGP)[0
SET PSGP=$PIECE($GET(^PS(53.1,DA,0)),"^",15)_"^1"
SET ZZ=+$GET(^PS(53.1,DA,.1))
SET ZZZ=+$GET(^PS(53.1,DA,"DSS"))
+2 IF PSGP
KILL ^PS(53.1,"AC",+PSGP,DA),^PS(53.1,"AS",X,+PSGP,DA),^PS(53.1,"AV",+PSGP,DA)
if ZZ
KILL ^PS(53.1,"AOD",+PSGP,ZZ,DA)
if ZZZ
KILL ^PS(53.1,"AD",ZZZ,+PSGP,DA)
+3 KILL ZZ,ZZZ
if $PIECE(PSGP,"^",2)
KILL PSGP
QUIT
+4 ;
ENNDS ; set x-refs under 53.1,.1
+1 SET ^PS(53.1,"D",X,DA)=""
if $DATA(PSGP)[0
SET PSGP=$PIECE($GET(^PS(53.1,DA,0)),"^",15)_"^1"
IF PSGP
SET PSGX=X
DO END^PSGSICHK
SET X=PSGX
SET PSGX=$PIECE($GET(^PS(53.1,DA,0)),"^",9)
IF $SELECT(PSGX["A":0,1:PSGX'["D")
SET ^PS(53.1,"AOD",+PSGP,X,DA)=""
+2 KILL PSGX
if $PIECE(PSGP,"^",2)
KILL PSGP
QUIT
+3 ;
ENNDK ; kill x-refs under 53.1,.1
+1 if $DATA(PSGP)[0
SET PSGP=$PIECE($GET(^PS(53.1,DA,0)),"^",15)_"^1"
KILL ^PS(53.1,"D",X,DA)
if PSGP
KILL ^PS(53.1,"AOD",+PSGP,X,DA)
if $PIECE(PSGP,"^",2)
KILL PSGP
QUIT
+2 ;
ENNPS ; set x-refs under 53.1,.5
+1 SET ^PS(53.1,"C",X,DA)=""
SET PSGX=$PIECE($GET(^PS(53.1,DA,0)),"^",9)
if PSGX]""
SET ^PS(53.1,"AS",PSGX,X,DA)=""
+2 IF $SELECT(PSGX["A":0,1:PSGX'["D")
SET ^PS(53.1,"AC",X,DA)=""
+3 IF PSGX="P"
IF +$PIECE($GET(^PS(53.1,DA,4)),U)
SET ^PS(53.1,"AV",X,DA)=""
+4 if PSGX
SET ^PS(53.1,"AOD",X,PSGX,DA)=""
+5 KILL PSGX
QUIT
+6 ;
ENNPK ; kill x-refs under 53.1,.5
+1 KILL ^PS(53.1,"AC",X,DA),^PS(53.1,"C",X,DA)
SET PSGX=$PIECE($GET(^PS(53.1,DA,0)),"^",9)
if PSGX]""
KILL ^PS(53.1,"AS",PSGX,X,DA)
SET PSGX=+$GET(^PS(53.1,DA,.1))
if PSGX
KILL ^PS(53.1,"AOD",X,PSGX,DA)
+2 KILL ^PS(53.1,"AV",X,DA)
+3 KILL PSGX
QUIT
ENNACK ; Set x-refs under Nurse verification for acknowleged pending orders.
+1 SET PSGX=$GET(^PS(53.1,DA,0))
SET PSGP=$PIECE(PSGX,U,15)
+2 SET PSGST=$PIECE(PSGX,U,9)
+3 IF PSGP
IF +X
IF (PSGST="P")
SET ^PS(53.1,"AV",PSGP,DA)=""
+4 KILL PSGX,PSGP,PSGST
QUIT
ENNACKK ; Kill x-refs under Nurse verification
+1 SET PSGP=$PIECE($GET(^PS(53.1,DA,0)),U,15)
+2 if +PSGP
KILL ^PS(53.1,"AV",+PSGP,DA)
QUIT
