- 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 Jan 18, 2025@03:02:51 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