PSGMMAR3 ;BIR/CML3-MD MARS - SORT O/P ORDERS ;21 Oct 98 / 12:22 PM
;;5.0; INPATIENT MEDICATIONS ;**20,111,131,145**;16 DEC 97;Build 17
;
; Reference to ^PS(59.7 supported by DBIA #2181.
;
S1 ; Print non-blank prn.
Q:PSGMARB=1
NEW INIT,NEED,LT,RT,BL,PG,LAB
S BL=$S($P($G(^PS(59.7,1,26)),U):6,1:4),(PG,LT,RT)=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"))="")
Q:NO
D NOW^%DTC S PSGDT=%,(DAO,DAOO)="",PST="N",PSGMAROC=0
K ^TMP($J,"1PRN")
I PSGSS'="P",PSGSS'="C",PSGSS'="L" D
. 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
. 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
I PSGSS="P"!(PSGSS="C")!(PSGSS="L") F S PST=$O(^TMP($J,PN,PWDN,PST)) Q:PST="" D
. N DAOO S DAOO=""
. 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
. Q
;
D EN^PSGMMAR4
Q
;
SET ; set ^tmp array
S PSGORD=$P(DAOO,U,2)
I PSGORD["V" D IVPRN^PSGMMIV Q
I +PSGMSORT,PSGORD["P" S PSJPSTO=PST,PST="OZ"
S PSGORD=+PSGORD_$S(PSGORD["P":"P",1:"A") D ^PSGLOI
S TS=0 D MARLB^PSGMUTL(47)
I ((MARLB/6)+PSGMAROC)>BL S:PSGMAROC PG=PG+1,(LT,RT)=1,PSGMAROC=0
I ((MARLB/6)+PSGMAROC)>(BL/2) S PSGMAROC=$S(PSGMAROC>(BL/2):PSGMAROC,1:(BL/2)) D LTRT(.RT,"^")
E D LTRT(.LT,"")
D LAB
I $D(PSJPSTO) S PST=PSJPSTO K PSJPSTO
Q
;
LAB ;***Print the 1st label for the order.
NEW X,J S J=0
;naked reference below goes with full reference on right of =
F X=1:1:MARLB S J=J+1,^(J)=$G(^TMP($J,"1PRN",PG,LAB,J))_UP_MARLB(X) D
. I X=6,(MARLB>6) D
. . S J=0
. . I PSGMAROC>(BL/2) D LTRT(.RT,"^")
. . E D LTRT(.LT,"")
Q
;
LTRT(X,Y) ;***Increment Left or Right label value.
S LAB=X,X=X+1,UP=Y,PSGMAROC=PSGMAROC+1
Q
BLANK ; Print blank prn form
NEW INIT,NEED,LT,RT,BL,PG,LAB,UP
S BL=$S($P($G(^PS(59.7,1,26)),U):6,1:4),(PG,LT,RT)=1
I PSGMARB'=2 D PSGMARB^PSGMMAR4
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGMMAR3 2211 printed Oct 16, 2024@18:02:24 Page 2
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
+2 ;
+3 ; Reference to ^PS(59.7 supported by DBIA #2181.
+4 ;
S1 ; Print non-blank prn.
+1 if PSGMARB=1
QUIT
+2 NEW INIT,NEED,LT,RT,BL,PG,LAB
+3 SET BL=$SELECT($PIECE($GET(^PS(59.7,1,26)),U):6,1:4)
SET (PG,LT,RT)=1
+4 SET NO=$SELECT(PSGSS="P"!(PSGSS="C")!(PSGSS="L"):$ORDER(^TMP($JOB,PN,PWDN,"N"))="",PSGRBPPN="P":$ORDER(^TMP($JOB,TM,WDN,PN,RB,"N"))="",1:$ORDER(^TMP($JOB,TM,WDN,RB,PN,"N"))="")
+5 if NO
QUIT
+6 DO NOW^%DTC
SET PSGDT=%
SET (DAO,DAOO)=""
SET PST="N"
SET PSGMAROC=0
+7 KILL ^TMP($JOB,"1PRN")
+8 IF PSGSS'="P"
IF PSGSS'="C"
IF PSGSS'="L"
Begin DoDot:1
+9 ;DAM 5-01-07 add XTMP global
IF PSGRBPPN="P"
FOR
SET PST=$ORDER(^XTMP(PSGREP,TM,PN,WDN,RB,PST))
if PST=""
QUIT
FOR
SET DAOO=$ORDER(^XTMP(PSGREP,TM,PN,WDN,RB,PST,DAOO))
if DAOO=""
QUIT
SET PSGMARTS=^(DAOO)
DO SET
+10 IF PSGRBPPN="R"
FOR
SET PST=$ORDER(^TMP($JOB,TM,WDN,RB,PN,PST))
if PST=""
QUIT
FOR
SET DAOO=$ORDER(^TMP($JOB,TM,WDN,RB,PN,PST,DAOO))
if DAOO=""
QUIT
SET PSGMARTS=^(DAOO)
DO SET
End DoDot:1
+11 IF PSGSS="P"!(PSGSS="C")!(PSGSS="L")
FOR
SET PST=$ORDER(^TMP($JOB,PN,PWDN,PST))
if PST=""
QUIT
Begin DoDot:1
+12 NEW DAOO
SET DAOO=""
+13 FOR
SET DAOO=$ORDER(^TMP($JOB,PN,PWDN,PST,DAOO))
if DAOO=""
QUIT
IF $DATA(^TMP($JOB,PN,PWDN,PST,DAOO))#10
SET PSGMARTS=^(DAOO)
DO SET
+14 QUIT
End DoDot:1
+15 ;
+16 DO EN^PSGMMAR4
+17 QUIT
+18 ;
SET ; set ^tmp array
+1 SET PSGORD=$PIECE(DAOO,U,2)
+2 IF PSGORD["V"
DO IVPRN^PSGMMIV
QUIT
+3 IF +PSGMSORT
IF PSGORD["P"
SET PSJPSTO=PST
SET PST="OZ"
+4 SET PSGORD=+PSGORD_$SELECT(PSGORD["P":"P",1:"A")
DO ^PSGLOI
+5 SET TS=0
DO MARLB^PSGMUTL(47)
+6 IF ((MARLB/6)+PSGMAROC)>BL
if PSGMAROC
SET PG=PG+1
SET (LT,RT)=1
SET PSGMAROC=0
+7 IF ((MARLB/6)+PSGMAROC)>(BL/2)
SET PSGMAROC=$SELECT(PSGMAROC>(BL/2):PSGMAROC,1:(BL/2))
DO LTRT(.RT,"^")
+8 IF '$TEST
DO LTRT(.LT,"")
+9 DO LAB
+10 IF $DATA(PSJPSTO)
SET PST=PSJPSTO
KILL PSJPSTO
+11 QUIT
+12 ;
LAB ;***Print the 1st label for the order.
+1 NEW X,J
SET J=0
+2 ;naked reference below goes with full reference on right of =
+3 FOR X=1:1:MARLB
SET J=J+1
SET ^(J)=$GET(^TMP($JOB,"1PRN",PG,LAB,J))_UP_MARLB(X)
Begin DoDot:1
+4 IF X=6
IF (MARLB>6)
Begin DoDot:2
+5 SET J=0
+6 IF PSGMAROC>(BL/2)
DO LTRT(.RT,"^")
+7 IF '$TEST
DO LTRT(.LT,"")
End DoDot:2
End DoDot:1
+8 QUIT
+9 ;
LTRT(X,Y) ;***Increment Left or Right label value.
+1 SET LAB=X
SET X=X+1
SET UP=Y
SET PSGMAROC=PSGMAROC+1
+2 QUIT
BLANK ; Print blank prn form
+1 NEW INIT,NEED,LT,RT,BL,PG,LAB,UP
+2 SET BL=$SELECT($PIECE($GET(^PS(59.7,1,26)),U):6,1:4)
SET (PG,LT,RT)=1
+3 IF PSGMARB'=2
DO PSGMARB^PSGMMAR4
+4 QUIT
