Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSGMMAR3

PSGMMAR3.m

Go to the documentation of this file.
  1. PSGMMAR3 ;BIR/CML3-MD MARS - SORT O/P ORDERS ;21 Oct 98 / 12:22 PM
  1. ;;5.0; INPATIENT MEDICATIONS ;**20,111,131,145**;16 DEC 97;Build 17
  1. ;
  1. ; Reference to ^PS(59.7 supported by DBIA #2181.
  1. ;
  1. S1 ; Print non-blank prn.
  1. Q:PSGMARB=1
  1. NEW INIT,NEED,LT,RT,BL,PG,LAB
  1. S BL=$S($P($G(^PS(59.7,1,26)),U):6,1:4),(PG,LT,RT)=1
  1. 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"))="")
  1. Q:NO
  1. D NOW^%DTC S PSGDT=%,(DAO,DAOO)="",PST="N",PSGMAROC=0
  1. K ^TMP($J,"1PRN")
  1. I PSGSS'="P",PSGSS'="C",PSGSS'="L" D
  1. . 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
  1. . 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
  1. I PSGSS="P"!(PSGSS="C")!(PSGSS="L") F S PST=$O(^TMP($J,PN,PWDN,PST)) Q:PST="" D
  1. . N DAOO S DAOO=""
  1. . 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
  1. . Q
  1. ;
  1. D EN^PSGMMAR4
  1. Q
  1. ;
  1. SET ; set ^tmp array
  1. S PSGORD=$P(DAOO,U,2)
  1. I PSGORD["V" D IVPRN^PSGMMIV Q
  1. I +PSGMSORT,PSGORD["P" S PSJPSTO=PST,PST="OZ"
  1. S PSGORD=+PSGORD_$S(PSGORD["P":"P",1:"A") D ^PSGLOI
  1. S TS=0 D MARLB^PSGMUTL(47)
  1. I ((MARLB/6)+PSGMAROC)>BL S:PSGMAROC PG=PG+1,(LT,RT)=1,PSGMAROC=0
  1. I ((MARLB/6)+PSGMAROC)>(BL/2) S PSGMAROC=$S(PSGMAROC>(BL/2):PSGMAROC,1:(BL/2)) D LTRT(.RT,"^")
  1. E D LTRT(.LT,"")
  1. D LAB
  1. I $D(PSJPSTO) S PST=PSJPSTO K PSJPSTO
  1. Q
  1. ;
  1. LAB ;***Print the 1st label for the order.
  1. NEW X,J S J=0
  1. ;naked reference below goes with full reference on right of =
  1. F X=1:1:MARLB S J=J+1,^(J)=$G(^TMP($J,"1PRN",PG,LAB,J))_UP_MARLB(X) D
  1. . I X=6,(MARLB>6) D
  1. . . S J=0
  1. . . I PSGMAROC>(BL/2) D LTRT(.RT,"^")
  1. . . E D LTRT(.LT,"")
  1. Q
  1. ;
  1. LTRT(X,Y) ;***Increment Left or Right label value.
  1. S LAB=X,X=X+1,UP=Y,PSGMAROC=PSGMAROC+1
  1. Q
  1. BLANK ; Print blank prn form
  1. NEW INIT,NEED,LT,RT,BL,PG,LAB,UP
  1. S BL=$S($P($G(^PS(59.7,1,26)),U):6,1:4),(PG,LT,RT)=1
  1. I PSGMARB'=2 D PSGMARB^PSGMMAR4
  1. Q