source: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGCAP0.m@ 1259

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

initial load of WorldVistAEHR

File size: 3.9 KB
Line 
1PSGCAP0 ;BIR/CML3-ACTION PROFILE ;12 Mar 98 / 9:30 AM
2 ;;5.0; INPATIENT MEDICATIONS ;**8,58,111,149**;16 DEC 97
3 ;
4 ; Reference to ^PS(55 is supported by DBIA# 2191
5 ; Reference to ^PSDRUG is supported by DBIA# 2192
6 ;
7GOD ; gather order data
8 S ND=$G(^PS(55,PSGP,5,PSJJORD,0)),ND2=$G(^(2)),SI=$P($G(^(6)),"^"),DRG=$G(^(.2)) ;WS=$S(DRG&PSGAPWD:$D(^PSI(58.1,"D",+DRG,PSGAPWD)),1:0)
9 S X=$$NFWS^PSJUTL1(PSGP,PSJJORD_"U",PSGAPWD) S NF=$P(X,U),WS=$P(X,U,2),SM=$S('$P(X,U,3):0,$P(X,U,4):1,1:2)
10 N X,PSG
11 D DRGDISP^PSJLMUT1(PSGP,PSJJORD_"U",20,0,.PSG,1)
12 S DRG=PSG(1),DRG=$S(DRG["NOT FOUND":"z",1:DRG) ;SM=$S('$P(ND,"^",5):0,$P(ND,"^",6):1,1:2)
13 S ST=$S($P(ND,U,27)="R"&($P(ND,U,9)="A"):"R",1:$P(ND,U,9)),ND=$P(ND,"^",7)
14 N DDRG S (X,DCU)=0 F S X=$O(^PS(55,PSGP,5,PSJJORD,1,X)) Q:'X S DDRG=^(X,0),DCU=DCU+($P($G(^PSDRUG(+DDRG,660)),"^",6)*($S($P(DDRG,"^",2):$P(DDRG,"^",2),1:1)))
15 ;
16 ;
17 S SD=$P(ND2,"^",2),FD=$P(ND2,"^",4) F X="SD","FD" S @X=$E($$ENDTC^PSGMI(@X),1,5)
18 ;S Y=SI S:Y]"" Y=$$ENSET^PSGSICHK(Y) S:'$G(PSGAPWDN) PSGAPWDN=PSJPWDN S ^TMP($J,S1,PSGAPWDN,PN,ND_"^"_DRG,PSJJORD)=ST_"^"_SD_"^"_FD_"^"_WS_"^"_SM_"^"_NF_"^"_DCU_"^"_DRG S:Y]"" ^(PSJJORD,1)=Y Q
19 S Y=SI S:Y]"" Y=$$ENSET^PSGSICHK(Y) S PSGAPWDN=$S($G(PSGAPWD)="zz":"zz",$G(PSGAPWDN):PSGAPWDN,'$G(PSGAPWDN):PSJPWDN,1:"zz"),^TMP($J,S1,PSGAPWDN,PN,ND_"^"_DRG,PSJJORD)=ST_"^"_SD_"^"_FD_"^"_WS_"^"_SM_"^"_NF_"^"_DCU_"^"_DRG S:Y]"" ^(PSJJORD,1)=Y Q
20 ;
21PAT ;
22 D PSJAC2^PSJAC(1),NOW^%DTC S PSGDT=%,PN=$E($P(PSGP(0),"^"),1,20)_"^"_PSGP
23 S S1="zz" I PSGAPS="T",PSJPWD,PSJPRB]"",$D(^PS(57.7,PSJPWD,1,+$O(^PS(57.7,"AWRT",PSJPWD,PSJPRB,0)),0)),$P(^(0),"^")]"" S S1=$P(^(0),"^")
24 I PSGAPS="P",PSJPTSP,$D(^VA(200,PSJPTSP,0)),$P(^(0),"^")]"" S S1=$P(^(0),"^")
25 S:PSGMTYPE[1 PSGMTYPE="2,3,4,5,6"
26 I PSGMTYPE[2 D
27 . F STRT=PSGAPSD-.0001:0 S STRT=$O(^PS(55,PSGP,5,"AUS",STRT)) Q:$S('STRT:1,PSGAPO="E":STRT>PSGAPFD,1:0) I STRT'=PSGAPSD F PSJJORD=0:0 S PSJJORD=$O(^PS(55,PSGP,5,"AUS",STRT,PSJJORD)) Q:'PSJJORD D GOD
28 . S XTYPE=2,PST="S" D ^PSGCAPIV
29 N XTYPE F XTYPE=3:1:6 I PSGMTYPE[XTYPE S PST=$S(XTYPE=3:"P",XTYPE=4:"A",XTYPE=5:"H",1:"C") D ^PSGCAPIV
30 I PSGMTYPE[3 S XTYPE=3,PST="S" D ^PSGCAPIV ;* Find syringe type iv
31 I $D(^TMP($J,S1,PSGAPWDN,PN)) S ^(PN)=$P(PSJPSEX,"^",2)_"^"_$E($P(PSJPDOB,"^",2),1,10)_";"_PSJPAGE_"^"_VA("PID")_"^"_PSJPDX_"^"_$S(PSJPRB]"":PSJPRB,1:"*NF*")_"^"_$E($P(PSJPAD,"^",2),1,10)_"^"_$E($P(PSJPTD,"^",2),1,10)
32 I S ^TMP($J,S1,PSGAPWDN,PN)=^(PN)_"^"_PSJPWT_"^"_PSJPWTD_"^"_PSJPHT_"^"_PSJPHTD_"^"_$P(PSGP(0),"^")
33 Q
34 ;
35ENQ ; queued entry point
36 N ALFLG,DCU,DRGI,DRGN,DRGT,KKA,HT,HTD,ON,PST,PSIVUP,PSJORIFN,QST,WTD,XTYPE
37 K ^TMP($J) S STT=PSGAPSD-.0001,PSJACNWP=1 D @("P"_PSGSS),^PSGCAPP D ^%ZISC
38 Q
39 ;
40PG ;
41 I PSGAPWD="zz" D CLIN Q
42 F PSGAPWD=0:0 S PSGAPWD=$O(^PS(57.5,"AC",PSGAPWG,PSGAPWD)) Q:'PSGAPWD I $D(^DIC(42,PSGAPWD,0)),$P(^(0),"^")]"" S PSGAPWDN=$P(^(0),"^") D PW
43 Q
44 ;
45PW ;
46 F PSGP=0:0 S PSGP=$O(^DPT("CN",PSGAPWDN,PSGP)) Q:'PSGP D PAT
47 Q
48 ;
49PP ;
50 F PSGP=0:0 S PSGP=$O(PSGPAT(PSGP)) Q:'PSGP S PSGAPWDN=$P($G(^DPT(PSGP,.1)),"^") S:PSGAPWDN]"" PSGAPWD=+$O(^DIC(42,"B",PSGAPWDN,0)) S:PSGAPWDN="" PSGAPWDN="zz" D PAT
51 Q
52 ;
53PL S CL="" F S CL=$O(^PS(57.8,"AD",CG,CL)) Q:CL="" D PC
54 Q
55PC S PSGAPWDN=$S($D(^SC(CL,0)):$P(^(0),"^"),1:"")
56 S PSGP="" F S PSGP=$O(^PS(53.1,"AD",CL,PSGP)) Q:PSGP="" D PAT
57 N INDEX,APSTOP
58 F INDEX="AIVC","AUDC" S APSTOP=0 F S APSTOP=$O(^PS(55,INDEX,APSTOP)) Q:'APSTOP D
59 . S DFN=0 F S DFN=$O(^PS(55,INDEX,APSTOP,CL,DFN)) Q:'DFN I '$D(^TMP("PSGAP0",$J,"OUTPT",DFN)) S PSGP=DFN,Q=APSTOP,PSGAPWD="zz" D PAT
60 Q
61CLIN ;
62 N INDEX,APSTOP,CLIN
63 F INDEX="AIVC","AUDC" S APSTOP=0 F S APSTOP=$O(^PS(55,INDEX,APSTOP)) Q:'APSTOP S CLIN=0 F S CLIN=$O(^PS(55,INDEX,APSTOP,CLIN)) Q:'CLIN D
64 . S DFN=0 F S DFN=$O(^PS(55,INDEX,APSTOP,CLIN,DFN)) Q:'DFN I '$D(^TMP("PSGAP0",$J,"OUTPT",DFN)) S PSGP=DFN,Q=APSTOP,PSGAPWD="zz" D PAT
65 Q
66 ;
67ENOR ;
68 D ENCV^PSGSETU I $D(XQUIT) Q
69 S (DFN,PSGP)=+ORVP D ^PSJAC S PSGPAT=PSGP,PSGPAT(DFN)="",(PSGAP,PSGAPWD,PSGAPWG)=0,(PSGAPWDN,PSGAPWGN)="",PSGSS="P" D ORS^PSGCAP S PSJNKF=1 D DONE^PSGCAP Q
Note: See TracBrowser for help on using the repository browser.