- ORPR010 ; slc/dcm - Silence of the prints
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**11,99**;Dec 17, 1997
- GET(ORHOOT,FMT,ORIFN,OACTION,ORVP,LOC,GIOM,DISP) ;Get display of a print format
- Q:'$G(FMT)
- I $G(DISP) W @IOF
- N X,IOM,IOF,TEST,OREND,ORPDAD
- Q:'$D(^OR(100,$G(ORIFN),0)) S X=^(0)
- S:'$G(OACTION) OACTION=1
- S:'$D(ORVP) ORVP=$P(X,"^",2)
- S:'$D(LOC) LOC=+$P(X,"^",10)
- S:'$G(GIOM) GIOM=79
- S IOM=GIOM,IOF="!",TEST=0
- I $G(DISP) D PRINT^ORPR00(FMT)
- N GCNT,CCNT
- S GCNT=1,CCNT=0
- D SHUSH(FMT,.ORHOOT,,.GCNT)
- Q
- SHUSH(FMT,ORHOOT,NUM,GCNT) ;
- ;FMT=Format ptr in ^ORD(100.23,FMT
- ;NUM=# of times to print
- ;^TMP("ORP:"_$J,... may be used by a print field
- Q:'$G(FMT) Q:'$D(^ORD(100.23,FMT,0)) Q:'$L($G(ORHOOT))
- N ORKI,ORK,X,ORTEST,OREND,ORPDAD,ORSILENT
- S ORSILENT=1 ;ORSILENT tells print utility not to display
- K ^TMP("ORP:"_$J)
- S OREND=0
- S:'$D(NUM) NUM=1
- I $D(^ORD(100.23,FMT,3)),$L(^(3)) X ^(3) I '$T Q ;Screen check!
- F ORKI=1:1:NUM Q:OREND D
- . S ORK=0 F S ORK=$O(^ORD(100.23,FMT,1,ORK)) Q:ORK'>0 I $D(^(ORK,0)) S X=+^(0) D
- .. I $G(ORIFN),$D(^ORD(100.22,+X,0)),$P(^(0),"^",7),$P(^(0),"^",7)'=$P($G(^OR(100,ORIFN,0)),"^",14) Q
- .. I $D(^ORD(100.22,+X,1)),'$P(^(0),"^",6) X ^(1)
- . S ORK=0 F S ORK=$O(^ORD(100.23,FMT,4,ORK)) Q:ORK'>0 X ^ORD(100.23,FMT,4,ORK,0) Q:OREND I $G(ORPICKUP) D K ORPICKUP
- .. S I=0 F S I=$O(@Y@(I)) Q:'I D LN^ORU4 S @ORHOOT@(GCNT,0)=@Y@(I,0)
- . K ^TMP("ORP:"_$J)
- Q
- CMPL(ORFMT) ;Compile Silent formatting code
- N ORROW,ORFL,ORK,OROUT,ORV,ORVAR,OROJ,ORCL,ORPT,I,X,CCNT,GCNT,ORPDAD
- Q:'$G(ORFMT) Q:'$D(^ORD(100.23,ORFMT,0)) S ORROW=$S($P(^(0),"^",2):$P(^(0),"^",2),1:6)
- S ORK=0 F S ORK=$O(^ORD(100.22,ORK)) Q:ORK'>0 I $D(^(ORK,0)),$L($P(^(0),"^",4)) S @$P(^(0),"^",4)=$P(^(0),"^",3)
- K ^ORD(100.23,ORFMT,4)
- S (CCNT,GCNT,ORFL,ORK,ORV)=0,OROUT="^ORD(100.23,ORFMT,4)"
- F S ORK=$O(^ORD(100.23,ORFMT,1,ORK)) Q:ORK'>0 I $D(^(ORK,0)) S X=^(0) D
- . S ^TMP("OR",$J,"FMT",+$P(X,"^",2),+$P(X,"^",3),$P(X,"^"))=$P(X,"^",4,7)
- F ORK=1:1:ORROW S:ORK>1 ORFL=1 D
- . I '$D(^TMP("OR",$J,"FMT",ORK)) D LN^ORU4 S @OROUT@(GCNT,0)="D LN^ORU4" Q
- . S ORCL=0 F S ORCL=$O(^TMP("OR",$J,"FMT",ORK,ORCL)) Q:ORCL'>0 S ORPT=$O(^(ORCL,"")),OROJ=^(ORPT) D STUF
- I $O(ORVAR(0)) S I=0,X="X" D
- . F S I=$O(ORVAR(I)) Q:I<1 S X=X_","_ORVAR(I)
- . D LN^ORU4 S @OROUT@(GCNT,0)="K "_X
- S @OROUT@(0)="^^"_GCNT_"^"_GCNT_"^"_DT
- S ORK=0 F S ORK=$O(^ORD(100.22,ORK)) Q:ORK'>0 I $D(^(ORK,0)),$L($P(^(0),"^",4)) K @$P(^(0),"^",4)
- K ^TMP("OR",$J,"FMT")
- Q
- STUF ;
- I $P(^ORD(100.22,+ORPT,0),"^",6),$D(^(1)),$L(^(1)) D LN^ORU4 S @OROUT@(GCNT,0)=^ORD(100.22,+ORPT,1) Q ;Direct execute (not compiled)
- N ORDEF,ORFUN,ORTL,ORPRM,X,X1
- S ORVAR="DT",ORDEF=""
- S:$D(^ORD(100.22,+ORPT,0)) ORVAR=$P(^(0),"^",4),ORDEF=$P(^(0),"^",2),ORFUN=$P(^(0),"^",5)
- I $D(^(1)),$L(^(1)) S ORV=ORV+1,ORVAR(ORV)=ORVAR
- S ORTL=$S(ORVAR="ORFREE":"",$P(OROJ,"^")="NONE":"",$P(OROJ,"^")]"":$P(OROJ,"^"),1:ORDEF),ORPRM=""""_$P(OROJ,"^",3)_"""",ORTL=""""_ORTL_""""
- I $P(OROJ,"^",4),$L(ORVAR),ORVAR'="ORFREE" S ORTL="$S($L($G("_ORVAR_")):"_ORTL_",1:"""")"
- I ORFL D LN^ORU4 S @OROUT@(GCNT,0)="D LN^ORU4"
- D LN^ORU4
- S @OROUT@(GCNT,0)="S:'$D(@ORHOOT@(GCNT,0)) @ORHOOT@(GCNT,0)="""""
- D LN^ORU4
- S @OROUT@(GCNT,0)="S X=$$S^ORU4("_(ORCL-1)_",.CCNT,"_ORTL_"_"_$S(ORVAR="ORFREE":""""_$P(OROJ,"^",2)_"""",$L(ORFUN):"$$"_ORFUN_"^ORU4($G("_ORVAR_"),"_ORPRM_",.ORHOOT,"_(ORCL-1)_",.GCNT,.CCNT)",1:"$G("_ORVAR_")")_",.CCNT)"
- D LN^ORU4
- S @OROUT@(GCNT,0)="I $D(@ORHOOT@(GCNT,0)),$D(X) S @ORHOOT@(GCNT,0)=@ORHOOT@(GCNT,0)_X"
- S ORFL=0
- Q
- OUT(OROOT) ;Display output
- N I,X
- Q:'$D(OROOT) Q:'$O(@OROOT@(0))
- F I=1:1 S X=$G(@OROOT@(I,0)) W !,X Q:'$O(@OROOT@(I))
- Q
- TEST(IFN,DISP) ;Test
- Q:'IFN
- N FMT
- S FMT=0
- F S FMT=$O(^ORD(100.23,FMT)) Q:'FMT D
- . N DAVE S DAVE="DAVE"
- . W !,FMT,?15,$P(^ORD(100.23,FMT,0),"^")
- . D GET(.DAVE,FMT,IFN,1),OUT("DAVE"):$G(DISP)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORPR010 3915 printed Jan 18, 2025@03:33:44 Page 2
- ORPR010 ; slc/dcm - Silence of the prints
- +1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**11,99**;Dec 17, 1997
- GET(ORHOOT,FMT,ORIFN,OACTION,ORVP,LOC,GIOM,DISP) ;Get display of a print format
- +1 if '$GET(FMT)
- QUIT
- +2 IF $GET(DISP)
- WRITE @IOF
- +3 NEW X,IOM,IOF,TEST,OREND,ORPDAD
- +4 if '$DATA(^OR(100,$GET(ORIFN),0))
- QUIT
- SET X=^(0)
- +5 if '$GET(OACTION)
- SET OACTION=1
- +6 if '$DATA(ORVP)
- SET ORVP=$PIECE(X,"^",2)
- +7 if '$DATA(LOC)
- SET LOC=+$PIECE(X,"^",10)
- +8 if '$GET(GIOM)
- SET GIOM=79
- +9 SET IOM=GIOM
- SET IOF="!"
- SET TEST=0
- +10 IF $GET(DISP)
- DO PRINT^ORPR00(FMT)
- +11 NEW GCNT,CCNT
- +12 SET GCNT=1
- SET CCNT=0
- +13 DO SHUSH(FMT,.ORHOOT,,.GCNT)
- +14 QUIT
- SHUSH(FMT,ORHOOT,NUM,GCNT) ;
- +1 ;FMT=Format ptr in ^ORD(100.23,FMT
- +2 ;NUM=# of times to print
- +3 ;^TMP("ORP:"_$J,... may be used by a print field
- +4 if '$GET(FMT)
- QUIT
- if '$DATA(^ORD(100.23,FMT,0))
- QUIT
- if '$LENGTH($GET(ORHOOT))
- QUIT
- +5 NEW ORKI,ORK,X,ORTEST,OREND,ORPDAD,ORSILENT
- +6 ;ORSILENT tells print utility not to display
- SET ORSILENT=1
- +7 KILL ^TMP("ORP:"_$JOB)
- +8 SET OREND=0
- +9 if '$DATA(NUM)
- SET NUM=1
- +10 ;Screen check!
- IF $DATA(^ORD(100.23,FMT,3))
- IF $LENGTH(^(3))
- XECUTE ^(3)
- IF '$TEST
- QUIT
- +11 FOR ORKI=1:1:NUM
- if OREND
- QUIT
- Begin DoDot:1
- +12 SET ORK=0
- FOR
- SET ORK=$ORDER(^ORD(100.23,FMT,1,ORK))
- if ORK'>0
- QUIT
- IF $DATA(^(ORK,0))
- SET X=+^(0)
- Begin DoDot:2
- +13 IF $GET(ORIFN)
- IF $DATA(^ORD(100.22,+X,0))
- IF $PIECE(^(0),"^",7)
- IF $PIECE(^(0),"^",7)'=$PIECE($GET(^OR(100,ORIFN,0)),"^",14)
- QUIT
- +14 IF $DATA(^ORD(100.22,+X,1))
- IF '$PIECE(^(0),"^",6)
- XECUTE ^(1)
- End DoDot:2
- +15 SET ORK=0
- FOR
- SET ORK=$ORDER(^ORD(100.23,FMT,4,ORK))
- if ORK'>0
- QUIT
- XECUTE ^ORD(100.23,FMT,4,ORK,0)
- if OREND
- QUIT
- IF $GET(ORPICKUP)
- Begin DoDot:2
- +16 SET I=0
- FOR
- SET I=$ORDER(@Y@(I))
- if 'I
- QUIT
- DO LN^ORU4
- SET @ORHOOT@(GCNT,0)=@Y@(I,0)
- End DoDot:2
- KILL ORPICKUP
- +17 KILL ^TMP("ORP:"_$JOB)
- End DoDot:1
- +18 QUIT
- CMPL(ORFMT) ;Compile Silent formatting code
- +1 NEW ORROW,ORFL,ORK,OROUT,ORV,ORVAR,OROJ,ORCL,ORPT,I,X,CCNT,GCNT,ORPDAD
- +2 if '$GET(ORFMT)
- QUIT
- if '$DATA(^ORD(100.23,ORFMT,0))
- QUIT
- SET ORROW=$SELECT($PIECE(^(0),"^",2):$PIECE(^(0),"^",2),1:6)
- +3 SET ORK=0
- FOR
- SET ORK=$ORDER(^ORD(100.22,ORK))
- if ORK'>0
- QUIT
- IF $DATA(^(ORK,0))
- IF $LENGTH($PIECE(^(0),"^",4))
- SET @$PIECE(^(0),"^",4)=$PIECE(^(0),"^",3)
- +4 KILL ^ORD(100.23,ORFMT,4)
- +5 SET (CCNT,GCNT,ORFL,ORK,ORV)=0
- SET OROUT="^ORD(100.23,ORFMT,4)"
- +6 FOR
- SET ORK=$ORDER(^ORD(100.23,ORFMT,1,ORK))
- if ORK'>0
- QUIT
- IF $DATA(^(ORK,0))
- SET X=^(0)
- Begin DoDot:1
- +7 SET ^TMP("OR",$JOB,"FMT",+$PIECE(X,"^",2),+$PIECE(X,"^",3),$PIECE(X,"^"))=$PIECE(X,"^",4,7)
- End DoDot:1
- +8 FOR ORK=1:1:ORROW
- if ORK>1
- SET ORFL=1
- Begin DoDot:1
- +9 IF '$DATA(^TMP("OR",$JOB,"FMT",ORK))
- DO LN^ORU4
- SET @OROUT@(GCNT,0)="D LN^ORU4"
- QUIT
- +10 SET ORCL=0
- FOR
- SET ORCL=$ORDER(^TMP("OR",$JOB,"FMT",ORK,ORCL))
- if ORCL'>0
- QUIT
- SET ORPT=$ORDER(^(ORCL,""))
- SET OROJ=^(ORPT)
- DO STUF
- End DoDot:1
- +11 IF $ORDER(ORVAR(0))
- SET I=0
- SET X="X"
- Begin DoDot:1
- +12 FOR
- SET I=$ORDER(ORVAR(I))
- if I<1
- QUIT
- SET X=X_","_ORVAR(I)
- +13 DO LN^ORU4
- SET @OROUT@(GCNT,0)="K "_X
- End DoDot:1
- +14 SET @OROUT@(0)="^^"_GCNT_"^"_GCNT_"^"_DT
- +15 SET ORK=0
- FOR
- SET ORK=$ORDER(^ORD(100.22,ORK))
- if ORK'>0
- QUIT
- IF $DATA(^(ORK,0))
- IF $LENGTH($PIECE(^(0),"^",4))
- KILL @$PIECE(^(0),"^",4)
- +16 KILL ^TMP("OR",$JOB,"FMT")
- +17 QUIT
- STUF ;
- +1 ;Direct execute (not compiled)
- IF $PIECE(^ORD(100.22,+ORPT,0),"^",6)
- IF $DATA(^(1))
- IF $LENGTH(^(1))
- DO LN^ORU4
- SET @OROUT@(GCNT,0)=^ORD(100.22,+ORPT,1)
- QUIT
- +2 NEW ORDEF,ORFUN,ORTL,ORPRM,X,X1
- +3 SET ORVAR="DT"
- SET ORDEF=""
- +4 if $DATA(^ORD(100.22,+ORPT,0))
- SET ORVAR=$PIECE(^(0),"^",4)
- SET ORDEF=$PIECE(^(0),"^",2)
- SET ORFUN=$PIECE(^(0),"^",5)
- +5 IF $DATA(^(1))
- IF $LENGTH(^(1))
- SET ORV=ORV+1
- SET ORVAR(ORV)=ORVAR
- +6 SET ORTL=$SELECT(ORVAR="ORFREE":"",$PIECE(OROJ,"^")="NONE":"",$PIECE(OROJ,"^")]"":$PIECE(OROJ,"^"),1:ORDEF)
- SET ORPRM=""""_$PIECE(OROJ,"^",3)_""""
- SET ORTL=""""_ORTL_""""
- +7 IF $PIECE(OROJ,"^",4)
- IF $LENGTH(ORVAR)
- IF ORVAR'="ORFREE"
- SET ORTL="$S($L($G("_ORVAR_")):"_ORTL_",1:"""")"
- +8 IF ORFL
- DO LN^ORU4
- SET @OROUT@(GCNT,0)="D LN^ORU4"
- +9 DO LN^ORU4
- +10 SET @OROUT@(GCNT,0)="S:'$D(@ORHOOT@(GCNT,0)) @ORHOOT@(GCNT,0)="""""
- +11 DO LN^ORU4
- +12 SET @OROUT@(GCNT,0)="S X=$$S^ORU4("_(ORCL-1)_",.CCNT,"_ORTL_"_"_$SELECT(ORVAR="ORFREE":""""_$PIECE(OROJ,"^",2)_"""",$LENGTH(ORFUN):"$$"_ORFUN_"^ORU4($G("_ORVAR_"),"_ORPRM_",.ORHOOT,"_(ORCL-1)_",.GCNT,.CCNT)",1:"$G("_ORVAR_")")_",.CCNT)"
- +13 DO LN^ORU4
- +14 SET @OROUT@(GCNT,0)="I $D(@ORHOOT@(GCNT,0)),$D(X) S @ORHOOT@(GCNT,0)=@ORHOOT@(GCNT,0)_X"
- +15 SET ORFL=0
- +16 QUIT
- OUT(OROOT) ;Display output
- +1 NEW I,X
- +2 if '$DATA(OROOT)
- QUIT
- if '$ORDER(@OROOT@(0))
- QUIT
- +3 FOR I=1:1
- SET X=$GET(@OROOT@(I,0))
- WRITE !,X
- if '$ORDER(@OROOT@(I))
- QUIT
- +4 QUIT
- TEST(IFN,DISP) ;Test
- +1 if 'IFN
- QUIT
- +2 NEW FMT
- +3 SET FMT=0
- +4 FOR
- SET FMT=$ORDER(^ORD(100.23,FMT))
- if 'FMT
- QUIT
- Begin DoDot:1
- +5 NEW DAVE
- SET DAVE="DAVE"
- +6 WRITE !,FMT,?15,$PIECE(^ORD(100.23,FMT,0),"^")
- +7 DO GET(.DAVE,FMT,IFN,1)
- if $GET(DISP)
- DO OUT("DAVE")
- End DoDot:1
- +8 QUIT