source: FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGAMSA.m@ 636

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