- ORPR00 ; slc/dcm - Prints Charming ;5/10/01 10:10
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**5,11,69,99,95**;Dec 17, 1997
- EN ;Formatter
- N ORIOF,D,DA,D0,DI,DIC,DE,DQ,DIE,DR,DTOUT,DUOUT,Y,ORFMT,DLAYGO,ORK,%,%Y,%X,Y,I
- S DIC="^ORD(100.23,",DIC(0)="AEMQL",DLAYGO=100.23
- D ^DIC I Y<0 G OUT
- S (ORFMT,DA)=+Y,DIE="^ORD(100.23,",DR="[OR PRINT FORMAT EDIT]"
- D ^DIE
- I '$D(^ORD(100.23,ORFMT,0)) G OUT
- ASK W !!," OK to compile print format"
- S %=1 D YN^DICN
- Q:%=-1
- I %=0 W !,"Answer YES to incorporate changes made into the compiled code." G ASK
- Q:%=2
- 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)
- D CMPL
- W !!,"|||||------------------------ Column Numbers ------------------------|||||"
- W !,"0---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8"
- W !,"1 0 0 0 0 0 0 0 0"
- S ORIOF=IOF,IOF="!"
- D PRINT(ORFMT,1,1)
- W !
- S IOF=ORIOF
- D CMPL^ORPR010(ORFMT)
- G EN
- OUT ;Clean-up before exit
- 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)
- Q
- CMPL ;Compile print code for output
- N X,I,ORROW,ORK,ORVAR,ORFL,ORAN,ORV,ORCL,OROJ,ORPT
- Q:'$D(^ORD(100.23,ORFMT,0)) S X=^(0)
- S ORROW=$S($P(X,"^",2):$P(X,"^",2),1:6)
- K ^ORD(100.23,ORFMT,2)
- S ORK=0 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)
- S ORAN=1,(ORFL,ORV)=0
- F ORK=1:1:ORROW S:ORK>1 ORFL=1 D
- . I '$D(^TMP("OR",$J,"FMT",ORK)) S ^ORD(100.23,ORFMT,2,ORAN,0)="W !",ORAN=ORAN+1 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 ORAN=ORAN+1 S I=0,X="X" D
- .F S I=$O(ORVAR(I)) Q:I<1 S X=X_","_ORVAR(I)
- .S ^ORD(100.23,ORFMT,2,ORAN,0)="K "_X
- S ^ORD(100.23,ORFMT,2,0)="^^"_ORAN_"^"_(ORAN+1)_"^"_DT
- I '$D(DIFROM) W !!?3,"... '",$P(^ORD(100.23,ORFMT,0),"^"),"' format has been compiled."
- K ^TMP("OR",$J,"FMT")
- Q
- STUF ;
- I $P(^ORD(100.22,+ORPT,0),"^",6),$D(^(1)),$L(^(1)) S ^ORD(100.23,ORFMT,2,ORAN,0)=^ORD(100.22,+ORPT,1),ORAN=ORAN+1 Q ;Direct execute (not compiled)
- N ORDEF,ORFUN,ORPRM,ORTL
- 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
- I ORFUN="WORD"!(ORFUN="TEXT")!(ORFUN="TEXTWRAP")!(ORFUN="TMPWRAP"),(@ORVAR="WORD")!(@ORVAR="TEXT") S @ORVAR="^ORD(100.22,"_+ORPT_",2)"
- 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:"""")"
- S ^ORD(100.23,ORFMT,2,ORAN,0)="W"_$S(ORVAR["ORTX":":$L($G("_ORVAR_")) ",1:" ")_$S(ORFL:"!",1:"")_"?"_(ORCL-1)_","_ORTL_","_$S(ORVAR="ORFREE":""""_$P(OROJ,"^",2)_"""",$L(ORFUN):"$$"_ORFUN_"^ORU($G("_ORVAR_"),"_ORPRM_")",1:"$G("_ORVAR_")")
- S ORAN=ORAN+1,ORFL=0
- Q
- PRINT(FMT,NUM,TEST,SNUM,ORSCREEN) ;
- ;FMT=Format ptr in ^ORD(100.23,FMT
- ;NUM=# of times to print
- ;TEST=1 using test data
- ;$D(SNUM) Suppresses form feed
- ;ORSCREEN=Mumps code envoked when item is screened
- ;^TMP("ORP:",$J,... may be used by a print field
- Q:'$G(FMT) Q:'$D(^ORD(100.23,FMT,0))
- N ORKI,ORK,X,ORTEST
- K ^TMP("ORP:",$J)
- S ORTEST=$G(TEST)
- S:'$D(NUM) NUM=1 S:'$D(TEST) TEST=0
- I 'TEST,$D(^ORD(100.23,FMT,3)),$L(^(3)) X ^(3) I '$T W:$E(IOST,1,2)="C-" !,"This item has been screened from printing." X:$L($G(ORSCREEN)) ORSCREEN H 2 Q
- F ORKI=1:1:NUM Q:$G(OREND) D
- . I 'TEST 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)
- . W:'$G(SNUM)!($E(IOST,1,2)="C-") @IOF W $C(13)
- . S ORK=0 F S ORK=$O(^ORD(100.23,FMT,2,ORK)) Q:ORK'>0 X ^ORD(100.23,FMT,2,ORK,0) Q:$G(OREND)
- . K ^TMP("ORP:",$J)
- . I $G(SNUM),NUM>1 W @IOF
- I $P(^ORD(100.23,FMT,0),"^",5),$G(NUM)<2 W @IOF
- Q
- RECMPL ;Recompile all print formats
- N IFN,ORK,X,ORFMT K ^TMP("OR",$J,"FMT")
- S IFN=0
- F S IFN=$O(^ORD(100.23,IFN)) Q:IFN<1 S ORFMT=IFN D
- . 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)
- . D CMPL
- . D CMPL^ORPR010(ORFMT)
- D OUT
- Q
- TEST(FMT,ORIFN,OACTION,ORVP,LOC,GIOM) ;Test display of a print format
- Q:'$G(FMT)
- 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
- D PRINT(FMT)
- Q
- 22 ;Remove Print fields and Print format entries above #1000
- N Y,DIK,ORK,DA
- X ^%ZOSF("UCI") Q:Y="DEV,CUR" Q:Y="OEX,ROX"
- S DIK="^ORD(100.22,"
- F ORK=1000:0 S ORK=$O(^ORD(100.22,ORK)) Q:ORK<1 S DA=ORK D ^DIK
- S DIK="^ORD(100.23,"
- F ORK=1000:0 S ORK=$O(^ORD(100.23,ORK)) Q:ORK<1 S DA=ORK D ^DIK
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORPR00 5123 printed Jan 18, 2025@03:33:42 Page 2
- ORPR00 ; slc/dcm - Prints Charming ;5/10/01 10:10
- +1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**5,11,69,99,95**;Dec 17, 1997
- EN ;Formatter
- +1 NEW ORIOF,D,DA,D0,DI,DIC,DE,DQ,DIE,DR,DTOUT,DUOUT,Y,ORFMT,DLAYGO,ORK,%,%Y,%X,Y,I
- +2 SET DIC="^ORD(100.23,"
- SET DIC(0)="AEMQL"
- SET DLAYGO=100.23
- +3 DO ^DIC
- IF Y<0
- GOTO OUT
- +4 SET (ORFMT,DA)=+Y
- SET DIE="^ORD(100.23,"
- SET DR="[OR PRINT FORMAT EDIT]"
- +5 DO ^DIE
- +6 IF '$DATA(^ORD(100.23,ORFMT,0))
- GOTO OUT
- ASK WRITE !!," OK to compile print format"
- +1 SET %=1
- DO YN^DICN
- +2 if %=-1
- QUIT
- +3 IF %=0
- WRITE !,"Answer YES to incorporate changes made into the compiled code."
- GOTO ASK
- +4 if %=2
- QUIT
- +5 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)
- +6 DO CMPL
- +7 WRITE !!,"|||||------------------------ Column Numbers ------------------------|||||"
- +8 WRITE !,"0---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8"
- +9 WRITE !,"1 0 0 0 0 0 0 0 0"
- +10 SET ORIOF=IOF
- SET IOF="!"
- +11 DO PRINT(ORFMT,1,1)
- +12 WRITE !
- +13 SET IOF=ORIOF
- +14 DO CMPL^ORPR010(ORFMT)
- +15 GOTO EN
- OUT ;Clean-up before exit
- +1 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)
- +2 QUIT
- CMPL ;Compile print code for output
- +1 NEW X,I,ORROW,ORK,ORVAR,ORFL,ORAN,ORV,ORCL,OROJ,ORPT
- +2 if '$DATA(^ORD(100.23,ORFMT,0))
- QUIT
- SET X=^(0)
- +3 SET ORROW=$SELECT($PIECE(X,"^",2):$PIECE(X,"^",2),1:6)
- +4 KILL ^ORD(100.23,ORFMT,2)
- +5 SET ORK=0
- FOR
- SET ORK=$ORDER(^ORD(100.23,ORFMT,1,ORK))
- if ORK'>0
- QUIT
- IF $DATA(^(ORK,0))
- SET X=^(0)
- Begin DoDot:1
- +6 SET ^TMP("OR",$JOB,"FMT",+$PIECE(X,"^",2),+$PIECE(X,"^",3),$PIECE(X,"^"))=$PIECE(X,"^",4,7)
- End DoDot:1
- +7 SET ORAN=1
- SET (ORFL,ORV)=0
- +8 FOR ORK=1:1:ORROW
- if ORK>1
- SET ORFL=1
- Begin DoDot:1
- +9 IF '$DATA(^TMP("OR",$JOB,"FMT",ORK))
- SET ^ORD(100.23,ORFMT,2,ORAN,0)="W !"
- SET ORAN=ORAN+1
- 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 ORAN=ORAN+1
- 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 SET ^ORD(100.23,ORFMT,2,ORAN,0)="K "_X
- End DoDot:1
- +14 SET ^ORD(100.23,ORFMT,2,0)="^^"_ORAN_"^"_(ORAN+1)_"^"_DT
- +15 IF '$DATA(DIFROM)
- WRITE !!?3,"... '",$PIECE(^ORD(100.23,ORFMT,0),"^"),"' format has been compiled."
- +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))
- SET ^ORD(100.23,ORFMT,2,ORAN,0)=^ORD(100.22,+ORPT,1)
- SET ORAN=ORAN+1
- QUIT
- +2 NEW ORDEF,ORFUN,ORPRM,ORTL
- +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)
- IF $DATA(^(1))
- IF $LENGTH(^(1))
- SET ORV=ORV+1
- SET ORVAR(ORV)=ORVAR
- +5 IF ORFUN="WORD"!(ORFUN="TEXT")!(ORFUN="TEXTWRAP")!(ORFUN="TMPWRAP")
- IF (@ORVAR="WORD")!(@ORVAR="TEXT")
- SET @ORVAR="^ORD(100.22,"_+ORPT_",2)"
- +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 SET ^ORD(100.23,ORFMT,2,ORAN,0)="W"_$SELECT(ORVAR["ORTX":":$L($G("_ORVAR_")) ",1:" ")_$SELECT(ORFL:"!",1:"")_"?"_(ORCL-1)_","_ORTL_","_$SELECT(ORVAR="ORFREE":""""_...
- ... $PIECE(OROJ,"^",2)_"""",$LENGTH(ORFUN):"$$"_ORFUN_"^ORU($G("_ORVAR_"),"_ORPRM_")",1:"$G("_ORVAR_")")
- +9 SET ORAN=ORAN+1
- SET ORFL=0
- +10 QUIT
- PRINT(FMT,NUM,TEST,SNUM,ORSCREEN) ;
- +1 ;FMT=Format ptr in ^ORD(100.23,FMT
- +2 ;NUM=# of times to print
- +3 ;TEST=1 using test data
- +4 ;$D(SNUM) Suppresses form feed
- +5 ;ORSCREEN=Mumps code envoked when item is screened
- +6 ;^TMP("ORP:",$J,... may be used by a print field
- +7 if '$GET(FMT)
- QUIT
- if '$DATA(^ORD(100.23,FMT,0))
- QUIT
- +8 NEW ORKI,ORK,X,ORTEST
- +9 KILL ^TMP("ORP:",$JOB)
- +10 SET ORTEST=$GET(TEST)
- +11 if '$DATA(NUM)
- SET NUM=1
- if '$DATA(TEST)
- SET TEST=0
- +12 IF 'TEST
- IF $DATA(^ORD(100.23,FMT,3))
- IF $LENGTH(^(3))
- XECUTE ^(3)
- IF '$TEST
- if $EXTRACT(IOST,1,2)="C-"
- WRITE !,"This item has been screened from printing."
- if $LENGTH($GET(ORSCREEN))
- XECUTE ORSCREEN
- HANG 2
- QUIT
- +13 FOR ORKI=1:1:NUM
- if $GET(OREND)
- QUIT
- Begin DoDot:1
- +14 IF 'TEST
- 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
- +15 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
- +16 IF $DATA(^ORD(100.22,+X,1))
- IF '$PIECE(^(0),"^",6)
- XECUTE ^(1)
- End DoDot:2
- +17 if '$GET(SNUM)!($EXTRACT(IOST,1,2)="C-")
- WRITE @IOF
- WRITE $CHAR(13)
- +18 SET ORK=0
- FOR
- SET ORK=$ORDER(^ORD(100.23,FMT,2,ORK))
- if ORK'>0
- QUIT
- XECUTE ^ORD(100.23,FMT,2,ORK,0)
- if $GET(OREND)
- QUIT
- +19 KILL ^TMP("ORP:",$JOB)
- +20 IF $GET(SNUM)
- IF NUM>1
- WRITE @IOF
- End DoDot:1
- +21 IF $PIECE(^ORD(100.23,FMT,0),"^",5)
- IF $GET(NUM)<2
- WRITE @IOF
- +22 QUIT
- RECMPL ;Recompile all print formats
- +1 NEW IFN,ORK,X,ORFMT
- KILL ^TMP("OR",$JOB,"FMT")
- +2 SET IFN=0
- +3 FOR
- SET IFN=$ORDER(^ORD(100.23,IFN))
- if IFN<1
- QUIT
- SET ORFMT=IFN
- Begin DoDot:1
- +4 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)
- +5 DO CMPL
- +6 DO CMPL^ORPR010(ORFMT)
- End DoDot:1
- +7 DO OUT
- +8 QUIT
- TEST(FMT,ORIFN,OACTION,ORVP,LOC,GIOM) ;Test display of a print format
- +1 if '$GET(FMT)
- QUIT
- +2 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 DO PRINT(FMT)
- +11 QUIT
- 22 ;Remove Print fields and Print format entries above #1000
- +1 NEW Y,DIK,ORK,DA
- +2 XECUTE ^%ZOSF("UCI")
- if Y="DEV,CUR"
- QUIT
- if Y="OEX,ROX"
- QUIT
- +3 SET DIK="^ORD(100.22,"
- +4 FOR ORK=1000:0
- SET ORK=$ORDER(^ORD(100.22,ORK))
- if ORK<1
- QUIT
- SET DA=ORK
- DO ^DIK
- +5 SET DIK="^ORD(100.23,"
- +6 FOR ORK=1000:0
- SET ORK=$ORDER(^ORD(100.23,ORK))
- if ORK<1
- QUIT
- SET DA=ORK
- DO ^DIK
- +7 QUIT