PSGAMSA ;BIR/CML3-ENTERS RETURNS, EXTRAS, & PRE-EX NEEDS INTO 57.6 ; 15 May 98 / 9:25 AM
;;5.0; INPATIENT MEDICATIONS ;**3,84,130**;16 DEC 97
;
; Reference to ^PS(55 is supported by DBIA# 2191.
; Reference to ^PSDRUG is supported by DBIA# 2192.
; Reference to ^ECXUD1 is supported by DBIA# 172.
;
EN(DFN,PSGORD,PSGORD1,PSGLOG) ;
; PSGLOG: 2 - pre-exchange needs, 3 - extra units dispensed, 4 - returns
N %,ECUD,LOG,ND,PSGAMSF,PSGDRG,PSGDRGC,PSGPRVR,PSGWARD,PSGX,VAIN,VAIP,PSGSTRT
S PSGX=X,PSGAMSF=$S(PSGLOG=4:2,1:0),PSGWARD=$P($G(^PS(55,DFN,5,PSGORD,0)),"^",23),PSGSTRT=$P($G(^PS(55,DFN,5,PSGORD,2)),"^",2)
; removed ref to DGPM.
;I 'PSGWARD D INP^VADPT S PSGWARD=+VAIN(4) I 'PSGWARD K VAIP S VAIP("E")=$O(^DGPM("ATID3",DFN,0)) I VAIP("E") S VAIP("E")=$O(^(VAIP("E"),0)) I VAIP("E") D IN5^VADPT S PSGWARD=+VAIP(17,4)
I 'PSGWARD D IN5^VADPT S PSGWARD=+VAIP(5) I 'PSGWARD K VAIP S VAIP("D")="L" D IN5^VADPT S PSGWARD=+VAIP(17,4)
S:'PSGWARD PSGWARD="999Z" S PSGPRVR=$S('$D(^PS(55,DFN,5,PSGORD,0)):"999Z",$P(^(0),"^",2):$P(^(0),"^",2),1:"999Z"),PSGDRG=$S('$D(^(1,PSGORD1,0)):"999Z",+^(0):+^(0),1:"999Z"),PSGDRGC=$S($D(^PSDRUG(PSGDRG,660)):$P(^(660),"^",6),1:0)*PSGX
D ENLOG,ENOPC
;
OUT ;
I PSGDRG=+PSGDRG,PSGPRVR=+PSGPRVR,PSGWARD=+PSGWARD D
. S X="ECXUD1" X ^%ZOSF("TEST")
. I S ECUD=DFN_"^"_DT_"^"_+PSGDRG_"^"_$S(PSGAMSF:-PSGX,1:+PSGX)_"^"_+PSGWARD_"^"_+PSGPRVR_";200^"_$S(PSGAMSF:-PSGDRGC,1:+PSGDRGC)_"^"_PSGSTRT_"^"_$G(PSGORD) D ^ECXUD1
Q
;
ENOPC ; outpatient entry point
F L +^PS(57.6,DT,1,PSGWARD,1,PSGPRVR,1,PSGDRG,0):0 I Q
I $D(^PS(57.6,DT,1,PSGWARD,1,PSGPRVR,1,PSGDRG,0)) S ND=^(0),X=1
E S ND=PSGDRG,X=0
S $P(ND,"^",2+PSGAMSF)=$P(ND,"^",2+PSGAMSF)+PSGX,$P(ND,"^",3+PSGAMSF)=$P(ND,"^",3+PSGAMSF)+PSGDRGC,^(0)=ND L -^PS(57.6,DT,1,PSGWARD,1,PSGPRVR,1,PSGDRG,0) Q:X ; naked from ENOPC+2
F L +^PS(57.6,DT,1,PSGWARD,1,PSGPRVR,1,0):1 I S ND=$S($D(^PS(57.6,DT,1,PSGWARD,1,PSGPRVR,1,0)):^(0),1:"^57.63P"),$P(ND,"^",3,4)=PSGDRG_"^"_PSGDRG,^(0)=ND L -^PS(57.6,DT,1,PSGWARD,1,PSGPRVR,1,0) Q
Q:$D(^PS(57.6,DT,1,PSGWARD,1,PSGPRVR,0)) S ^(0)=PSGPRVR
F L +^PS(57.6,DT,1,PSGWARD,1,0):1 I S ND=$S($D(^PS(57.6,DT,1,PSGWARD,1,0)):^(0),1:"^57.62P"),$P(ND,"^",3,4)=PSGPRVR_"^"_PSGPRVR,^(0)=ND L -^PS(57.6,DT,1,PSGWARD,1,0) Q
Q:$D(^PS(57.6,DT,1,PSGWARD,0)) S ^(0)=PSGWARD
F L +^PS(57.6,DT,1,0):1 I S ND=$S($D(^PS(57.6,DT,1,0)):^(0),1:"^57.61"),$P(ND,"^",3,4)=PSGWARD_"^"_PSGWARD,^(0)=ND L -^PS(57.6,DT,1,0) Q
I '$D(^PS(57.6,DT,0)) S ^(0)=DT F L +^PS(57.6,0):1 I S ND=$S($D(^PS(57.6,0)):^(0),1:"UNIT DOSE PICK LIST STATS^57.6D"),$P(ND,"^",3)=DT,$P(ND,"^",4)=$P(ND,"^",4)+1,^(0)=ND L -^PS(57.6,0) Q
Q
;
ENPLF(DFN,PSGORD,PSGDRG,PSGX,PSGDRGC,PSGLOG,PSGWARD,PSGPRVR,PSGPLFDT) ;
N DA,LOG,ND
;
ENLOG ;
D:'$D(PSGPLFDT) NOW^%DTC F L +^PS(55,DFN,5,PSGORD,11,0):0 Q:$T
S ND=$G(^PS(55,DFN,5,PSGORD,11,0)) S:$P(ND,"^",2)="" $P(ND,"^",2)="55.0611D"
F LOG=$P(ND,"^",3)+1:1 I '$D(^PS(55,DFN,5,PSGORD,11,LOG)) L +^PS(55,DFN,5,PSGORD,11,LOG):0 I S ^PS(55,DFN,5,PSGORD,11,LOG,0)=$S($D(PSGPLFDT):PSGPLFDT,1:%),^PS(55,DFN,5,PSGORD,11,"B",$S($D(PSGPLFDT):PSGPLFDT,1:%),LOG)="" Q
S $P(ND,"^",3)=LOG,$P(ND,"^",4)=$P(ND,"^",4)+1,^PS(55,DFN,5,PSGORD,11,0)=ND L -^PS(55,DFN,5,PSGORD,11,0)
S ^PS(55,DFN,5,PSGORD,11,LOG,0)=$S($D(PSGPLFDT):PSGPLFDT,1:%)_"^"_$S(PSGDRG=+PSGDRG:PSGDRG,1:"")_"^"_PSGX_"^"_PSGDRGC_"^"_PSGLOG_"^"_DUZ_"^"_$S(PSGWARD=+PSGWARD:PSGWARD,1:"")_"^"_$S(PSGPRVR=+PSGPRVR:PSGPRVR,1:"")
L -^PS(55,DFN,5,PSGORD,11,LOG)
Q
CLEANUP ; Clean up partial orders having no provider or status.
F DFN=0:0 S DFN=$O(^PS(55,DFN)) Q:'DFN F ON=0:0 S ON=$O(^PS(55,DFN,5,ON)) Q:'ON S X=$G(^(+ON,0)) I $P(X,U,2)_$P(X,U,9)="" W !,DFN," ",ON D DIK
Q
DIK ;
;K DA S DA(1)=DFN,DA=+ON,DIK="^PS(55,"_DA(1)_",5," D ^DIK K ^PS(55,DA(1),5,"B",DA,DA),^PS(55,"AUDDD",PSGPO,DA(1),DA),^PS(55,"AUE",DA(1),DA)
K ^PS(55,+DFN,5,+ON),^PS(55,+DFN,5,"B",+ON,+ON),^PS(55,"AUE",+DFN,+ON)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGAMSA 3937 printed Nov 22, 2024@17:10:51 Page 2
PSGAMSA ;BIR/CML3-ENTERS RETURNS, EXTRAS, & PRE-EX NEEDS INTO 57.6 ; 15 May 98 / 9:25 AM
+1 ;;5.0; INPATIENT MEDICATIONS ;**3,84,130**;16 DEC 97
+2 ;
+3 ; Reference to ^PS(55 is supported by DBIA# 2191.
+4 ; Reference to ^PSDRUG is supported by DBIA# 2192.
+5 ; Reference to ^ECXUD1 is supported by DBIA# 172.
+6 ;
EN(DFN,PSGORD,PSGORD1,PSGLOG) ;
+1 ; PSGLOG: 2 - pre-exchange needs, 3 - extra units dispensed, 4 - returns
+2 NEW %,ECUD,LOG,ND,PSGAMSF,PSGDRG,PSGDRGC,PSGPRVR,PSGWARD,PSGX,VAIN,VAIP,PSGSTRT
+3 SET PSGX=X
SET PSGAMSF=$SELECT(PSGLOG=4:2,1:0)
SET PSGWARD=$PIECE($GET(^PS(55,DFN,5,PSGORD,0)),"^",23)
SET PSGSTRT=$PIECE($GET(^PS(55,DFN,5,PSGORD,2)),"^",2)
+4 ; removed ref to DGPM.
+5 ;I 'PSGWARD D INP^VADPT S PSGWARD=+VAIN(4) I 'PSGWARD K VAIP S VAIP("E")=$O(^DGPM("ATID3",DFN,0)) I VAIP("E") S VAIP("E")=$O(^(VAIP("E"),0)) I VAIP("E") D IN5^VADPT S PSGWARD=+VAIP(17,4)
+6 IF 'PSGWARD
DO IN5^VADPT
SET PSGWARD=+VAIP(5)
IF 'PSGWARD
KILL VAIP
SET VAIP("D")="L"
DO IN5^VADPT
SET PSGWARD=+VAIP(17,4)
+7 if 'PSGWARD
SET PSGWARD="999Z"
SET PSGPRVR=$SELECT('$DATA(^PS(55,DFN,5,PSGORD,0)):"999Z",$PIECE(^(0),"^",2):$PIECE(^(0),"^",2),1:"999Z")
SET PSGDRG=$SELECT('$DATA(^(1,PSGORD1,0)):"999Z",+^(0):+^(0),1:"999Z")
SET PSGDRGC=$SELECT($DATA(^PSDRUG(PSGDRG,660)):$PIECE(^(660),"^",6),1:0)*PSGX
+8 DO ENLOG
DO ENOPC
+9 ;
OUT ;
+1 IF PSGDRG=+PSGDRG
IF PSGPRVR=+PSGPRVR
IF PSGWARD=+PSGWARD
Begin DoDot:1
+2 SET X="ECXUD1"
XECUTE ^%ZOSF("TEST")
+3 IF $TEST
SET ECUD=DFN_"^"_DT_"^"_+PSGDRG_"^"_$SELECT(PSGAMSF:-PSGX,1:+PSGX)_"^"_+PSGWARD_"^"_+PSGPRVR_";200^"_$SELECT(PSGAMSF:-PSGDRGC,1:+PSGDRGC)_"^"_PSGSTRT_"^"_$GET(PSGORD)
DO ^ECXUD1
End DoDot:1
+4 QUIT
+5 ;
ENOPC ; outpatient entry point
+1 FOR
LOCK +^PS(57.6,DT,1,PSGWARD,1,PSGPRVR,1,PSGDRG,0):0
IF $TEST
QUIT
+2 IF $DATA(^PS(57.6,DT,1,PSGWARD,1,PSGPRVR,1,PSGDRG,0))
SET ND=^(0)
SET X=1
+3 IF '$TEST
SET ND=PSGDRG
SET X=0
+4 ; naked from ENOPC+2
SET $PIECE(ND,"^",2+PSGAMSF)=$PIECE(ND,"^",2+PSGAMSF)+PSGX
SET $PIECE(ND,"^",3+PSGAMSF)=$PIECE(ND,"^",3+PSGAMSF)+PSGDRGC
SET ^(0)=ND
LOCK -^PS(57.6,DT,1,PSGWARD,1,PSGPRVR,1,PSGDRG,0)
if X
QUIT
+5 FOR
LOCK +^PS(57.6,DT,1,PSGWARD,1,PSGPRVR,1,0):1
IF $TEST
SET ND=$SELECT($DATA(^PS(57.6,DT,1,PSGWARD,1,PSGPRVR,1,0)):^(0),1:"^57.63P")
SET $PIECE(ND,"^",3,4)=PSGDRG_"^"_PSGDRG
SET ^(0)=ND
LOCK -^PS(57.6,DT,1,PSGWARD,1,PSGPRVR,1,0)
QUIT
+6 if $DATA(^PS(57.6,DT,1,PSGWARD,1,PSGPRVR,0))
QUIT
SET ^(0)=PSGPRVR
+7 FOR
LOCK +^PS(57.6,DT,1,PSGWARD,1,0):1
IF $TEST
SET ND=$SELECT($DATA(^PS(57.6,DT,1,PSGWARD,1,0)):^(0),1:"^57.62P")
SET $PIECE(ND,"^",3,4)=PSGPRVR_"^"_PSGPRVR
SET ^(0)=ND
LOCK -^PS(57.6,DT,1,PSGWARD,1,0)
QUIT
+8 if $DATA(^PS(57.6,DT,1,PSGWARD,0))
QUIT
SET ^(0)=PSGWARD
+9 FOR
LOCK +^PS(57.6,DT,1,0):1
IF $TEST
SET ND=$SELECT($DATA(^PS(57.6,DT,1,0)):^(0),1:"^57.61")
SET $PIECE(ND,"^",3,4)=PSGWARD_"^"_PSGWARD
SET ^(0)=ND
LOCK -^PS(57.6,DT,1,0)
QUIT
+10 IF '$DATA(^PS(57.6,DT,0))
SET ^(0)=DT
FOR
LOCK +^PS(57.6,0):1
IF $TEST
SET ND=$SELECT($DATA(^PS(57.6,0)):^(0),1:"UNIT DOSE PICK LIST STATS^57.6D")
SET $PIECE(ND,"^",3)=DT
SET $PIECE(ND,"^",4)=$PIECE(ND,"^",4)+1
SET ^(0)=ND
LOCK -^PS(57.6,0)
QUIT
+11 QUIT
+12 ;
ENPLF(DFN,PSGORD,PSGDRG,PSGX,PSGDRGC,PSGLOG,PSGWARD,PSGPRVR,PSGPLFDT) ;
+1 NEW DA,LOG,ND
+2 ;
ENLOG ;
+1 if '$DATA(PSGPLFDT)
DO NOW^%DTC
FOR
LOCK +^PS(55,DFN,5,PSGORD,11,0):0
if $TEST
QUIT
+2 SET ND=$GET(^PS(55,DFN,5,PSGORD,11,0))
if $PIECE(ND,"^",2)=""
SET $PIECE(ND,"^",2)="55.0611D"
+3 FOR LOG=$PIECE(ND,"^",3)+1:1
IF '$DATA(^PS(55,DFN,5,PSGORD,11,LOG))
LOCK +^PS(55,DFN,5,PSGORD,11,LOG):0
IF $TEST
SET ^PS(55,DFN,5,PSGORD,11,LOG,0)=$SELECT($DATA(PSGPLFDT):PSGPLFDT,1:%)
SET ^PS(55,DFN,5,PSGORD,11,"B",$SELECT($DATA(PSGPLFDT):PSGPLFDT,1:%),LOG)=""
QUIT
+4 SET $PIECE(ND,"^",3)=LOG
SET $PIECE(ND,"^",4)=$PIECE(ND,"^",4)+1
SET ^PS(55,DFN,5,PSGORD,11,0)=ND
LOCK -^PS(55,DFN,5,PSGORD,11,0)
+5 SET ^PS(55,DFN,5,PSGORD,11,LOG,0)=$SELECT($DATA(PSGPLFDT):PSGPLFDT,1:%)_"^"_$SELECT(PSGDRG=+PSGDRG:PSGDRG,1:"")_"^"_PSGX_"^"_PSGDRGC_"^"_PSGLOG_"^"_DUZ_"^"_$SELECT(PSGWARD=+PSGWARD:PSGWARD,1:"")_"^"_$SELECT(PSGPRVR=+PSGPRVR:PSGPRVR,1:"")
+6 LOCK -^PS(55,DFN,5,PSGORD,11,LOG)
+7 QUIT
CLEANUP ; Clean up partial orders having no provider or status.
+1 FOR DFN=0:0
SET DFN=$ORDER(^PS(55,DFN))
if 'DFN
QUIT
FOR ON=0:0
SET ON=$ORDER(^PS(55,DFN,5,ON))
if 'ON
QUIT
SET X=$GET(^(+ON,0))
IF $PIECE(X,U,2)_$PIECE(X,U,9)=""
WRITE !,DFN," ",ON
DO DIK
+2 QUIT
DIK ;
+1 ;K DA S DA(1)=DFN,DA=+ON,DIK="^PS(55,"_DA(1)_",5," D ^DIK K ^PS(55,DA(1),5,"B",DA,DA),^PS(55,"AUDDD",PSGPO,DA(1),DA),^PS(55,"AUE",DA(1),DA)
+2 KILL ^PS(55,+DFN,5,+ON),^PS(55,+DFN,5,"B",+ON,+ON),^PS(55,"AUE",+DFN,+ON)
+3 QUIT
