| 1 | PSGMMAR3 ;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 | ;
|
|---|
| 6 | S1 ; 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 | ;
|
|---|
| 25 | SET ; 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 | ;
|
|---|
| 38 | LAB ;***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 | ;
|
|---|
| 48 | LTRT(X,Y) ;***Increment Left or Right label value.
|
|---|
| 49 | S LAB=X,X=X+1,UP=Y,PSGMAROC=PSGMAROC+1
|
|---|
| 50 | Q
|
|---|
| 51 | BLANK ; 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
|
|---|
