source: FOIAVistA/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGAMSA.m@ 1423

Last change on this file since 1423 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 3.8 KB
Line 
1PSGAMSA ;BIR/CML3-ENTERS RETURNS, EXTRAS, & PRE-EX NEEDS INTO 57.6 ; 15 May 98 / 9:25 AM
2 ;;5.0; INPATIENT MEDICATIONS ;**3,84,130**;16 DEC 97
3 ;
4 ; Reference to ^PS(55 is supported by DBIA# 2191.
5 ; Reference to ^PSDRUG is supported by DBIA# 2192.
6 ; Reference to ^ECXUD1 is supported by DBIA# 172.
7 ;
8EN(DFN,PSGORD,PSGORD1,PSGLOG) ;
9 ; PSGLOG: 2 - pre-exchange needs, 3 - extra units dispensed, 4 - returns
10 N %,ECUD,LOG,ND,PSGAMSF,PSGDRG,PSGDRGC,PSGPRVR,PSGWARD,PSGX,VAIN,VAIP,PSGSTRT
11 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)
12 ; removed ref to DGPM.
13 ;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)
14 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)
15 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
16 D ENLOG,ENOPC
17 ;
18OUT ;
19 I PSGDRG=+PSGDRG,PSGPRVR=+PSGPRVR,PSGWARD=+PSGWARD D
20 . S X="ECXUD1" X ^%ZOSF("TEST")
21 . I S ECUD=DFN_"^"_DT_"^"_+PSGDRG_"^"_$S(PSGAMSF:-PSGX,1:+PSGX)_"^"_+PSGWARD_"^"_+PSGPRVR_";200^"_$S(PSGAMSF:-PSGDRGC,1:+PSGDRGC)_"^"_PSGSTRT_"^"_$G(PSGORD) D ^ECXUD1
22 Q
23 ;
24ENOPC ; outpatient entry point
25 F L +^PS(57.6,DT,1,PSGWARD,1,PSGPRVR,1,PSGDRG,0):0 I Q
26 I $D(^PS(57.6,DT,1,PSGWARD,1,PSGPRVR,1,PSGDRG,0)) S ND=^(0),X=1
27 E S ND=PSGDRG,X=0
28 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
29 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
30 Q:$D(^PS(57.6,DT,1,PSGWARD,1,PSGPRVR,0)) S ^(0)=PSGPRVR
31 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
32 Q:$D(^PS(57.6,DT,1,PSGWARD,0)) S ^(0)=PSGWARD
33 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
34 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
35 Q
36 ;
37ENPLF(DFN,PSGORD,PSGDRG,PSGX,PSGDRGC,PSGLOG,PSGWARD,PSGPRVR,PSGPLFDT) ;
38 N DA,LOG,ND
39 ;
40ENLOG ;
41 D:'$D(PSGPLFDT) NOW^%DTC F L +^PS(55,DFN,5,PSGORD,11,0):0 Q:$T
42 S ND=$G(^PS(55,DFN,5,PSGORD,11,0)) S:$P(ND,"^",2)="" $P(ND,"^",2)="55.0611D"
43 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
44 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)
45 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:"")
46 L -^PS(55,DFN,5,PSGORD,11,LOG)
47 Q
48CLEANUP ; Clean up partial orders having no provider or status.
49 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
50 Q
51DIK ;
52 ;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)
53 K ^PS(55,+DFN,5,+ON),^PS(55,+DFN,5,"B",+ON,+ON),^PS(55,"AUE",+DFN,+ON)
54 Q
Note: See TracBrowser for help on using the repository browser.