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