source: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJOEA2.m@ 701

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

initial load of WorldVistAEHR

File size: 4.9 KB
Line 
1PSJOEA2 ;BIR/MLM-INPATIENT ORDER ENTRY ;23 Jun 98 / 1:46 PM
2 ;;5.0; INPATIENT MEDICATIONS ;**127,133**;16 DEC 97
3 ;
4 ; Reference to ^PS(55 is supported by DBIA #2191.
5 ; Reference to ^PSSLOCK is supported by DBIA #2789.
6 ;
7CHK ;Check to be sure all the orders in the complex order series are completed, continued.
8 I 'PSJCOMV,'$G(COMQUIT) N PSJO S PSJO=0 F S PSJO=$O(^TMP("PSJCOM",$J,PSJO)) Q:'PSJO S PSGORD=+PSJO_"P",PSGND=$G(^PS(53.1,+PSJO,0)) D
9 .S PSGP=$P(PSGND,"^",15)
10 .I $P(PSGND,U,4)="U",$P(PSGND,U,9)="A",($P(PSGND,U,24)'="R") D ^PSGOT D Q
11 ..M ^PS(55,PSGP,5,+PSGORD,4)=^PS(53.1,PSJO,4)
12 ..N PSGND2P5 S PSGND2P5=$G(^PS(53.1,+PSJO,2.5)),DUR=$P(PSGND2P5,"^",2) I $G(DUR)]"" N DA,DR,DIE S DIE="^PS(55,"_PSGP_",5,",DA(1)=PSGP,DA=+PSGORD,DR="126////"_$G(DUR) D ^DIE
13 ..D ACTLOG^PSJOEA(PSJO,PSGP,PSGORD)
14 ..S VND4=$G(^PS(55,PSGP,5,+PSGORD,4))
15 ..I PSJSYSL>1 S $P(^PS(55,PSGP,5,+PSGORD,7),U)=PSGDT S:$P(^(7),U,2)="" $P(^(7),U,2)="N"_$S($P(^PS(55,PSGP,5,+PSGORD,0),"^",24)="E":"E",1:"") S PSGTOL=2,PSGUOW=DUZ,PSGTOO=1,DA=+PSGORD D ENL^PSGVDS
16 ..S:$P(VND4,"^",15)&'$P(VND4,"^",16) $P(VND4,"^",15)="" S:$P(VND4,"^",18)&'$P(VND4,"^",19) $P(VND4,"^",18)="" S:$P(VND4,"^",22)&'$P(VND4,"^",23) $P(VND4,"^",22)="" S $P(VND4,"^",PSJSYSU,PSJSYSU+1)=DUZ_"^"_PSGDT,^PS(55,PSGP,5,+PSGORD,4)=VND4
17 ..I '$P(VND4,U,10) S ^PS(55,"ANV",PSGP,+PSGORD)=""
18 ..I $P(VND4,U,9) K ^PS(55,"APV",PSGP,+PSGORD)
19 ..I $P(VND4,U,10) K ^PS(55,"ANV",PSGP,+PSGORD)
20 ..S:+PSJSYSU=3 ^PS(55,"AUE",PSGP,+PSGORD)=""
21 ..S PSJCOM=$P($G(^PS(55,PSGP,5,+PSGORD,.2)),"^",8) I PSJCOM]"" K ^PS(53.1,"ACX",PSJCOM,PSJO) S $P(^PS(55,PSGP,5,+PSGORD,4),"^",9)=1
22 ..D EN1^PSJHL2(PSGP,$S(+PSJSYSU=3:"SC",+PSJSYSU=1:"SC",1:"XX"),+PSGORD_"U") ; allow status change to be sent for pharmacists & nurses
23 ..D:+PSJSYSU=1 EN1^PSJHL2(PSGP,"ZV",+PSGORD_"U") L -^PS(55,PSGP,5,+PSGORD)
24 ..S PSJPREX=1 D CMPLX2^PSJCOM1(PSGP,PSJORD,PSGORD) K PSJPREX
25 .I $P(PSGND,U,4)'="U",$P(PSGND,U,9)="A" D GT531^PSIVORFA(PSGP,PSJO_"P") D Q
26 ..S ON55="" I $P(PSGND,"^",24)="R" S ON55=$P(PSGND,"^",25) D
27 ...N PND0,PSGORDR S PND0=^PS(53.1,+PSJO,0),PSGORDR=$P(PND0,U,25)
28 ...Q:'$$LS^PSSLOCK(PSGP,PSGORDR)
29 ...N OEORD,OOEORD,FILE55,FILE55N0,PNDP2 S PNDP2=^PS(53.1,+PSJO,.2),FILE55="^PS(55,"_DFN_",""IV"",",FILE55N0=FILE55_+PSGORDR_",0)"
30 ...S OEORD=$P(PND0,U,21) I PSGORDR S OOEORD=$P(@FILE55N0,"^",21) I OEORD'=OOEORD D EXPOE^PSGOER(DFN,+PSJO_"P",+$$LASTREN^PSJLMPRI(DFN,+PSJO_"P"))
31 ...S PSGORDP=PSJO,DIE="^PS(53.1,",DA=+PSJO,DR="28////A;104////@" W "." D ^DIE
32 ...Q:'$G(OEORD) K DA,DR,DIE S DA(1)=DFN,DA=+PSGORDR,DIE=FILE55,DR=110_"////"_+OEORD
33 ...S:$P(PNDP2,U,8) DR=DR_";150////"_$P(PNDP2,U,8) D ^DIE S DIE=FILE55_+PSGORDR_",0)",$P(@DIE,U,21)=OEORD
34 ...D EN1^PSJHL2(DFN,"SC",PSGORDR),UNL^PSSLOCK(PSGP,PSGORDR)
35 ..I 'ON55 D SETNEW^PSIVORFB
36 ..S (P("NEWON"),ON)=ON55,PSGP=$P(PSGND,U,15)
37 ..S VND4=$G(^TMP("PSJCOM",$J,+PSJO,4)) D
38 ...N PSJRN,PSJRNDT,PSJRPH,PSJRPHD,PSJPVFL,PSJNVFL,DR,DIE,DA
39 ...S (PSJPVFL,PSJNVFL)=""
40 ...S PSJRN=$P(VND4,U,1),PSJRNDT=$P(VND4,U,2),PSJRPH=$P(VND4,U,3),PSJRPHD=$P(VND4,U,4),PSJPVFL=$P(VND4,U,16) S:PSJRN]"" PSJNVFL=1
41 ...S DR="16////"_PSJRN_";17////"_PSJRNDT_";140////"_PSJRPH_";141////"_PSJRPHD_";142////"_PSJPVFL_";143////"_PSJNVFL
42 ...S DA(1)=PSGP,DA=+ON55,DIE="^PS(55,"_PSGP_",""IV""," D ^DIE
43 ..D:P("RES")="R" RUPDATE^PSIVOREN(PSGP,ON,P(2))
44 ..I +PSJSYSU=3 K OD D ^PSIVORE1 ;LABEL STUFF
45 ..I $G(P("PACT"))]"",+$P(P("PACT"),U,2),+$P(P("PACT"),U,3) D Q
46 ...NEW DIC,DA,X,Y,XX D NAME^PSJBCMA1($P(P("PACT"),U,2),.XX)
47 ...S DIC(0)="L",DA(1)=DFN,DA(2)=+ON55,X=1
48 ...S DIC="^PS(55,"_DA(1)_",""IV"","_DA(2)_",""A"","
49 ...S DIC("DR")=".02////F;.03////"_XX_";.04////"_$P($G(^PS(53.3,+$P(P("PACT"),U,3),0)),U)_";.05////"_$P(P("PACT"),U)_";.06////"_$P(P("PACT"),U,2)
50 ...K DO D FILE^DICN K DO
51 ...N DIK,DA,PSIVACT S DIK="^PS(55,"_DFN_",""IV"",",DA=+ON,PSIVACT="" S:$G(DFN) DA(1)=DFN D IX^DIK K DIK,DA
52 ...S PSJCOM=$P($G(^PS(55,DFN,"IV",+ON,.2)),"^",8) I PSJCOM]"" K ^PS(53.1,"ACX",PSJCOM,PSJO)
53 ...D EN1^PSJHL2(DFN,"SC",ON)
54 ...D:+PSJSYSU=1 EN1^PSJHL2(DFN,"ZV",ON) L -^PS(55,DFN,"IV",+ON) I $G(ON55) L -^PS(55,DFN,"IV",+ON55)
55 ..L -^PS(55,DFN,"IV",+ON) I $G(ON55) L -^PS(55,DFN,"IV",+ON55)
56 .I $P(PSGND,U,4)="U",$P(PSGND,U,9)="DE",$D(^TMP("PSJCOM2",$J,PSJO,0)),$P(^TMP("PSJCOM2",$J,PSJO,0),"^",9)="A",$P(^TMP("PSJCOM2",$J,PSJO,0),"^",4)="U" S PSGP=$P(PSGND,U,15) D UD^PSJOEA
57 .I $P(PSGND,U,4)'="U",$P(PSGND,U,9)="DE",$D(^TMP("PSJCOM2",$J,PSJO,0)),$P(^TMP("PSJCOM2",$J,PSJO,0),"^",9)="A",$P(^TMP("PSJCOM2",$J,PSJO,0),"^",4)="U" S PSGP=$P(PSGND,U,15) D UD^PSJOEA
58 .I $P(PSGND,U,4)'="U",$P(PSGND,U,9)="DE",$D(^TMP("PSJCOM2",$J,PSJO,0)),$P(^TMP("PSJCOM2",$J,PSJO,0),"^",4)'="U",$P(^TMP("PSJCOM2",$J,PSJO,0),"^",17)="A" S DFN=$S($G(PSGP)]"":PSGP,1:$P(PSGND,U,15)) D IV^PSJOEA
59 .I $P(PSGND,U,4)="U",$P(PSGND,U,9)="DE",$D(^TMP("PSJCOM2",$J,PSJO,0)),$P(^TMP("PSJCOM2",$J,PSJO,0),"^",4)'="U",$P(^TMP("PSJCOM2",$J,PSJO,0),"^",17)="A" S DFN=$S($G(PSGP)]"":PSGP,1:$P(PSGND,U,15)) D IV^PSJOEA
60 K ^TMP("PSJCOM",$J),^TMP("PSJCOM2",$J),PSJOWALL
61 Q
Note: See TracBrowser for help on using the repository browser.