source: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGMMAR3.m@ 1147

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

initial load of WorldVistAEHR

File size: 2.1 KB
Line 
1PSGMMAR3 ;BIR/CML3-MD MARS - SORT O/P ORDERS ;21 Oct 98 / 12:22 PM
2 ;;5.0; INPATIENT MEDICATIONS ;**20,111,131,145**;16 DEC 97;Build 17
3 ;
4 ; Reference to ^PS(59.7 supported by DBIA #2181.
5 ;
6S1 ; Print non-blank prn.
7 Q:PSGMARB=1
8 NEW INIT,NEED,LT,RT,BL,PG,LAB
9 S BL=$S($P($G(^PS(59.7,1,26)),U):6,1:4),(PG,LT,RT)=1
10 S NO=$S(PSGSS="P"!(PSGSS="C")!(PSGSS="L"):$O(^TMP($J,PN,PWDN,"N"))="",PSGRBPPN="P":$O(^TMP($J,TM,WDN,PN,RB,"N"))="",1:$O(^TMP($J,TM,WDN,RB,PN,"N"))="")
11 Q:NO
12 D NOW^%DTC S PSGDT=%,(DAO,DAOO)="",PST="N",PSGMAROC=0
13 K ^TMP($J,"1PRN")
14 I PSGSS'="P",PSGSS'="C",PSGSS'="L" D
15 . I PSGRBPPN="P" F S PST=$O(^XTMP(PSGREP,TM,PN,WDN,RB,PST)) Q:PST="" F S DAOO=$O(^XTMP(PSGREP,TM,PN,WDN,RB,PST,DAOO)) Q:DAOO="" S PSGMARTS=^(DAOO) D SET ;DAM 5-01-07 add XTMP global
16 . I PSGRBPPN="R" F S PST=$O(^TMP($J,TM,WDN,RB,PN,PST)) Q:PST="" F S DAOO=$O(^TMP($J,TM,WDN,RB,PN,PST,DAOO)) Q:DAOO="" S PSGMARTS=^(DAOO) D SET
17 I PSGSS="P"!(PSGSS="C")!(PSGSS="L") F S PST=$O(^TMP($J,PN,PWDN,PST)) Q:PST="" D
18 . N DAOO S DAOO=""
19 . F S DAOO=$O(^TMP($J,PN,PWDN,PST,DAOO)) Q:DAOO="" I $D(^TMP($J,PN,PWDN,PST,DAOO))#10 S PSGMARTS=^(DAOO) D SET
20 . Q
21 ;
22 D EN^PSGMMAR4
23 Q
24 ;
25SET ; set ^tmp array
26 S PSGORD=$P(DAOO,U,2)
27 I PSGORD["V" D IVPRN^PSGMMIV Q
28 I +PSGMSORT,PSGORD["P" S PSJPSTO=PST,PST="OZ"
29 S PSGORD=+PSGORD_$S(PSGORD["P":"P",1:"A") D ^PSGLOI
30 S TS=0 D MARLB^PSGMUTL(47)
31 I ((MARLB/6)+PSGMAROC)>BL S:PSGMAROC PG=PG+1,(LT,RT)=1,PSGMAROC=0
32 I ((MARLB/6)+PSGMAROC)>(BL/2) S PSGMAROC=$S(PSGMAROC>(BL/2):PSGMAROC,1:(BL/2)) D LTRT(.RT,"^")
33 E D LTRT(.LT,"")
34 D LAB
35 I $D(PSJPSTO) S PST=PSJPSTO K PSJPSTO
36 Q
37 ;
38LAB ;***Print the 1st label for the order.
39 NEW X,J S J=0
40 ;naked reference below goes with full reference on right of =
41 F X=1:1:MARLB S J=J+1,^(J)=$G(^TMP($J,"1PRN",PG,LAB,J))_UP_MARLB(X) D
42 . I X=6,(MARLB>6) D
43 . . S J=0
44 . . I PSGMAROC>(BL/2) D LTRT(.RT,"^")
45 . . E D LTRT(.LT,"")
46 Q
47 ;
48LTRT(X,Y) ;***Increment Left or Right label value.
49 S LAB=X,X=X+1,UP=Y,PSGMAROC=PSGMAROC+1
50 Q
51BLANK ; Print blank prn form
52 NEW INIT,NEED,LT,RT,BL,PG,LAB,UP
53 S BL=$S($P($G(^PS(59.7,1,26)),U):6,1:4),(PG,LT,RT)=1
54 I PSGMARB'=2 D PSGMARB^PSGMMAR4
55 Q
Note: See TracBrowser for help on using the repository browser.