- DIP3 ;SFISC/GFT,TKW-PRINT HEADING, PAGE, COPIES ;15NOV2012
- ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
- ;;Per VA Directive 6402, this routine should not be modified.
- ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
- ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
- ;;Licensed under the terms of the Apache License, Version 2.0.
- ;
- I DJ,DE]"" S DJ=DJ+1,^UTILITY("DIP2",$J,DJ)=DE,DE=""
- H G G:((L?1"]".E)!($G(DDXP)=2)!($G(DDXP)=4)) I '$D(DIASKHD),'L G:$D(DALL)>9 G G PAGE
- D HD
- S DA=X D HQ^DIP31 G Q^DIP:$D(DTOUT)!($D(DUOUT)) K DIRUT,DIROUT
- S DHD=X G G:X=DA,G:$$DHD(.DHD,DK,L),H
- ;
- DHD(DHD,DK,L) ;VALIDATE HEADER 'DHD' FOR FILE 'DK'
- ; 'L'=0 MEANS SILENT
- ; CALLED BY SCREENMAN TEMPLATE EDIT
- N DC,X,Y,DIC,DD,%,DW
- I DHD?.P1"["1.E F DC=1,2 S X=$P($P(DHD,"[",DC+1),"]",1) D D^DIP21 S DIC(0)=$E("E",L)_"SF",DIC("S")="I '$D(^(""DCL"")) "_DIC("S") D IX^DIC K DIC G DHDBAD:Y<0&$L(X) I Y>0 S DHD=$P(DHD,"[",1,DC)_"["_$P(Y,U,2)_"]"_$P(DHD,"]",DC+1,9) W:L !
- I DHD'?1"W ".E Q DHD'[""""
- I DUZ(0)'="@" F %=1:2 Q:$P(DHD,"""",%,999)="" I $P($E(DHD,3,999),"""",%)[" " G DHDBAD
- Q 1
- DHDBAD Q 0
- ;
- G S DHD=$G(DHD) G PUT^DIP21:$S(L?1"]".E:1,$D(DALL)>9:1,$D(DALL):0,1:$L(DE)>13!DJ),PAGE
- X W $C(7),!,$$EZBLD^DIALOG(8086) S X="^" G Q^DIP ;**CCO/NI 'BAD DEVICE'
- ;
- PAGE ;
- K DICOMPX,DA,IO("C") S DISUPNO=$G(DISUPNO),DIPCRIT=$G(DIPCRIT),DC=$S($G(DDXP)'=4:",",1:"") S:$D(DOUT)#2 DA=DOUT I 'L,$D(PG) S DC=C_(PG-1) K PG
- EGP E I L,DHD'="@" F X=1:1:DPP I $D(DPP(X,"F")) W !,$$EZBLD^DIALOG(7096),"1// " R X:DTIME S:'$T X=U Q:X="" G DIP3^DIQQQ:X["?",X:X[U,DIP3:X\1'=X S DC=C_(X-1) Q ;*CCO/NI 'START AT PAGE:'
- I $G(DIFIXPT)=1 G F2 ;AVOID DEVICE SELECTION!!!
- I $D(%ZIS)[0,$D(^%ZTSK),$D(^%ZTSCH("RUN")),$D(^%ZOSF("UCI")),$D(^DD("OS",DISYS,8)) S %ZIS="QM",%ZIS("B")=""
- ZIS S:$D(IOP) DIOP=IOP D:$G(DDXP)=4 ZIS^DDXP4 D ^%ZIS S:$D(DIOP) IOP=DIOP K DIOP G X:POP
- I $G(DDXP)=4 S IOM=DDXPIOM,IOSL=$S(IOSL<DDXPIOSL:DDXPIOSL,1:IOSL),X=$S(IOM<255:IOM,1:0) X ^DD("OS",DISYS,"RM")
- I $D(IOT),IOT="SDP",$D(^DD("OS",DISYS,"SDP")) G SDP
- G FREE
- ;
- SDP S O=IO,DIPION=ION
- I '$D(DCOPIES) W !,$$EZBLD^DIALOG(8180) R F:DTIME G SDPCLO:F[U!'$T,SDP:F\1'=F S DCOPIES=F ;**CCO/NI NUMBER OF COPIES
- O K IOP,%ZIS S:$D(IO("Q")) %ZIS="NM",IOP="Q",%ZIS("B")="",DIOQ=1 S %ZIS("A")=$$EZBLD^DIALOG(8181) ;**CCO/NI 'OUTPUT COPIES TO:'
- D ^%ZIS G SDPCLO:POP,O:IO=O
- S DOUT=$S($D(ION):ION_";"_IOM_";"_IOST,1:IO),DA=IO,IOP=DIPION_";"_IOM_";"_IOST S:$D(DIOQ) %ZIS="QN",IOP="Q;"_IOP K DIOQ D ^%ZIS
- FREE S %=2,F=IOST["K",W=IOST["SINGLE"
- I $D(DIPZ),'$D(IOP),IO(0)=$I,$D(^DIPT(DIPZ,"IOM")),^("IOM")>IOM W $C(7),$$EZBLD^DIALOG(8190,^("IOM")) D YN^DICN G X:%<0,ZIS:%-1 ;**CCO/NI 'MARGIN WIDTH IS NORMALLY...'
- I IO(0)'=IO,'$D(IO("Q")),'$D(IOP)!$D(IOFREE),'W!F,IO(0)=$I,$S($D(DA):DA'=$I,1:1),$S($D(%ZIS)[0:1,1:%ZIS'["F"),$P(^DD("OS",DISYS,0),U,5) S %=2 W !,$$EZBLD^DIALOG(8191) D YN^DICN G CLO:%<0,DIP3^DIQQ:'% I %=1 ;**CCO/NI 'WANT TO FREE ..?'
- I $T!$D(IO("C")) W !,$$EZBLD^DIALOG(8192),! S IO("C")=1,X=$I,DM="" X ^DD("FUNC",7,1) K IO(1,IO) S:$D(DIOEND)#2 DIOEND(9)=DIOEND,DM="X DIOEND(9) " S DIOEND=DM_$S($D(^%ZIS("C")):"G H^XUS",1:"H") ;**CCO/NI 'TERMINAL IS FREE'
- F2 S X=$G(DHD) D HD:X="" S DHD=X,X=DC
- K DC,S,N,Q,H,DA,FR,TO,DM,J,T,V,CP,DIC,DIE,DRK,DINS,DALL S O=0,DK=DI,DC=X,C=","
- G ^DIP4:$D(IO("Q")) D CLEAN^DIEFU G ^DIP5
- ;
- SDPCLO S X=O G CLO1
- CLO S X=IO
- CLO1 X ^DD("FUNC",7,1) K:$D(IO)#2&(IO]"") IO(1,IO) G X
- ;
- HD S X=$$EZBLD^DIALOG($S($D(DCL)>9:8110,$D(DIAX):8111,$D(DIAR):8112,$D(DIS)>9:8109,1:8066),$$FILENAME^DIALOGZ(+DK)) ;**CCO/NI MAKE THE HEADER
- I $D(DC(0)),$D(^DIPT(DC(0),"H")),$S('$G(^("HLANG")):1,1:^("HLANG")=$G(DUZ("LANG"))) S X=^("H") ;**CCO/NI USE TEMPLATE HEADER UNLESS IT'S WRONG LANGUAGE
- I $D(DIASKHD),$D(DHD)#2 S:DHD'["?" (DIASKHD,X)=DHD S:DIASKHD'="" (X,DHD)=DIASKHD
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIP3 3828 printed Jan 18, 2025@03:53:44 Page 2
- DIP3 ;SFISC/GFT,TKW-PRINT HEADING, PAGE, COPIES ;15NOV2012
- +1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
- +4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
- +5 ;;Licensed under the terms of the Apache License, Version 2.0.
- +6 ;
- +7 IF DJ
- IF DE]""
- SET DJ=DJ+1
- SET ^UTILITY("DIP2",$JOB,DJ)=DE
- SET DE=""
- H if ((L?1"]".E)!($GET(DDXP)=2)!($GET(DDXP)=4))
- GOTO G
- IF '$DATA(DIASKHD)
- IF 'L
- if $DATA(DALL)>9
- GOTO G
- GOTO PAGE
- +1 DO HD
- +2 SET DA=X
- DO HQ^DIP31
- if $DATA(DTOUT)!($DATA(DUOUT))
- GOTO Q^DIP
- KILL DIRUT,DIROUT
- +3 SET DHD=X
- if X=DA
- GOTO G
- if $$DHD(.DHD,DK,L)
- GOTO G
- GOTO H
- +4 ;
- DHD(DHD,DK,L) ;VALIDATE HEADER 'DHD' FOR FILE 'DK'
- +1 ; 'L'=0 MEANS SILENT
- +2 ; CALLED BY SCREENMAN TEMPLATE EDIT
- +3 NEW DC,X,Y,DIC,DD,%,DW
- +4 IF DHD?.P1"["1.E
- FOR DC=1,2
- SET X=$PIECE($PIECE(DHD,"[",DC+1),"]",1)
- DO D^DIP21
- SET DIC(0)=$EXTRACT("E",L)_"SF"
- SET DIC("S")="I '$D(^(""DCL"")) "_DIC("S")
- DO IX^DIC
- KILL DIC
- if Y<0&$LENGTH(X)
- GOTO DHDBAD
- IF Y>0
- SET DHD=$PIECE(DHD,"[",1,DC)_"["_$PIECE(Y,U,2)_"]"_$PIECE(DHD,"]",DC+1,9)
- if L
- WRITE !
- +5 IF DHD'?1"W ".E
- QUIT DHD'[""""
- +6 IF DUZ(0)'="@"
- FOR %=1:2
- if $PIECE(DHD,"""",%,999)=""
- QUIT
- IF $PIECE($EXTRACT(DHD,3,999),"""",%)[" "
- GOTO DHDBAD
- +7 QUIT 1
- DHDBAD QUIT 0
- +1 ;
- G SET DHD=$GET(DHD)
- if $SELECT(L?1"]".E:1,$DATA(DALL)>9:1,$DATA(DALL):0,1:$LENGTH(DE)>13!DJ)
- GOTO PUT^DIP21
- GOTO PAGE
- X ;**CCO/NI 'BAD DEVICE'
- WRITE $CHAR(7),!,$$EZBLD^DIALOG(8086)
- SET X="^"
- GOTO Q^DIP
- +1 ;
- PAGE ;
- +1 KILL DICOMPX,DA,IO("C")
- SET DISUPNO=$GET(DISUPNO)
- SET DIPCRIT=$GET(DIPCRIT)
- SET DC=$SELECT($GET(DDXP)'=4:",",1:"")
- if $DATA(DOUT)#2
- SET DA=DOUT
- IF 'L
- IF $DATA(PG)
- SET DC=C_(PG-1)
- KILL PG
- EGP ;*CCO/NI 'START AT PAGE:'
- IF '$TEST
- IF L
- IF DHD'="@"
- FOR X=1:1:DPP
- IF $DATA(DPP(X,"F"))
- WRITE !,$$EZBLD^DIALOG(7096),"1// "
- READ X:DTIME
- if '$TEST
- SET X=U
- if X=""
- QUIT
- if X["?"
- GOTO DIP3^DIQQQ
- if X[U
- GOTO X
- if X\1'=X
- GOTO DIP3
- SET DC=C_(X-1)
- QUIT
- +1 ;AVOID DEVICE SELECTION!!!
- IF $GET(DIFIXPT)=1
- GOTO F2
- +2 IF $DATA(%ZIS)[0
- IF $DATA(^%ZTSK)
- IF $DATA(^%ZTSCH("RUN"))
- IF $DATA(^%ZOSF("UCI"))
- IF $DATA(^DD("OS",DISYS,8))
- SET %ZIS="QM"
- SET %ZIS("B")=""
- ZIS if $DATA(IOP)
- SET DIOP=IOP
- if $GET(DDXP)=4
- DO ZIS^DDXP4
- DO ^%ZIS
- if $DATA(DIOP)
- SET IOP=DIOP
- KILL DIOP
- if POP
- GOTO X
- +1 IF $GET(DDXP)=4
- SET IOM=DDXPIOM
- SET IOSL=$SELECT(IOSL<DDXPIOSL:DDXPIOSL,1:IOSL)
- SET X=$SELECT(IOM<255:IOM,1:0)
- XECUTE ^DD("OS",DISYS,"RM")
- +2 IF $DATA(IOT)
- IF IOT="SDP"
- IF $DATA(^DD("OS",DISYS,"SDP"))
- GOTO SDP
- +3 GOTO FREE
- +4 ;
- SDP SET O=IO
- SET DIPION=ION
- +1 ;**CCO/NI NUMBER OF COPIES
- IF '$DATA(DCOPIES)
- WRITE !,$$EZBLD^DIALOG(8180)
- READ F:DTIME
- if F[U!'$TEST
- GOTO SDPCLO
- if F\1'=F
- GOTO SDP
- SET DCOPIES=F
- O ;**CCO/NI 'OUTPUT COPIES TO:'
- KILL IOP,%ZIS
- if $DATA(IO("Q"))
- SET %ZIS="NM"
- SET IOP="Q"
- SET %ZIS("B")=""
- SET DIOQ=1
- SET %ZIS("A")=$$EZBLD^DIALOG(8181)
- +1 DO ^%ZIS
- if POP
- GOTO SDPCLO
- if IO=O
- GOTO O
- +2 SET DOUT=$SELECT($DATA(ION):ION_";"_IOM_";"_IOST,1:IO)
- SET DA=IO
- SET IOP=DIPION_";"_IOM_";"_IOST
- if $DATA(DIOQ)
- SET %ZIS="QN"
- SET IOP="Q;"_IOP
- KILL DIOQ
- DO ^%ZIS
- FREE SET %=2
- SET F=IOST["K"
- SET W=IOST["SINGLE"
- +1 ;**CCO/NI 'MARGIN WIDTH IS NORMALLY...'
- IF $DATA(DIPZ)
- IF '$DATA(IOP)
- IF IO(0)=$IO
- IF $DATA(^DIPT(DIPZ,"IOM"))
- IF ^("IOM")>IOM
- WRITE $CHAR(7),$$EZBLD^DIALOG(8190,^("IOM"))
- DO YN^DICN
- if %<0
- GOTO X
- if %-1
- GOTO ZIS
- +2 ;**CCO/NI 'WANT TO FREE ..?'
- IF IO(0)'=IO
- IF '$DATA(IO("Q"))
- IF '$DATA(IOP)!$DATA(IOFREE)
- IF 'W!F
- IF IO(0)=$IO
- IF $SELECT($DATA(DA):DA'=$IO,1:1)
- IF $SELECT($DATA(%ZIS)[0:1,1:%ZIS'["F")
- IF $PIECE(^DD("OS",DISYS,0),U,5)
- SET %=2
- WRITE !,$$EZBLD^DIALOG(8191)
- DO YN^DICN
- if %<0
- GOTO CLO
- if '%
- GOTO DIP3^DIQQ
- IF %=1
- +3 ;**CCO/NI 'TERMINAL IS FREE'
- IF $TEST!$DATA(IO("C"))
- WRITE !,$$EZBLD^DIALOG(8192),!
- SET IO("C")=1
- SET X=$IO
- SET DM=""
- XECUTE ^DD("FUNC",7,1)
- KILL IO(1,IO)
- if $DATA(DIOEND)#2
- SET DIOEND(9)=DIOEND
- SET DM="X DIOEND(9) "
- SET DIOEND=DM_$SELECT($DATA(^%ZIS("C")):"G H^XUS",1:"H")
- F2 SET X=$GET(DHD)
- if X=""
- DO HD
- SET DHD=X
- SET X=DC
- +1 KILL DC,S,N,Q,H,DA,FR,TO,DM,J,T,V,CP,DIC,DIE,DRK,DINS,DALL
- SET O=0
- SET DK=DI
- SET DC=X
- SET C=","
- +2 if $DATA(IO("Q"))
- GOTO ^DIP4
- DO CLEAN^DIEFU
- GOTO ^DIP5
- +3 ;
- SDPCLO SET X=O
- GOTO CLO1
- CLO SET X=IO
- CLO1 XECUTE ^DD("FUNC",7,1)
- if $DATA(IO)#2&(IO]"")
- KILL IO(1,IO)
- GOTO X
- +1 ;
- HD ;**CCO/NI MAKE THE HEADER
- SET X=$$EZBLD^DIALOG($SELECT($DATA(DCL)>9:8110,$DATA(DIAX):8111,$DATA(DIAR):8112,$DATA(DIS)>9:8109,1:8066),$$FILENAME^DIALOGZ(+DK))
- +1 ;**CCO/NI USE TEMPLATE HEADER UNLESS IT'S WRONG LANGUAGE
- IF $DATA(DC(0))
- IF $DATA(^DIPT(DC(0),"H"))
- IF $SELECT('$GET(^("HLANG")):1,1:^("HLANG")=$GET(DUZ("LANG")))
- SET X=^("H")
- +2 IF $DATA(DIASKHD)
- IF $DATA(DHD)#2
- if DHD'["?"
- SET (DIASKHD,X)=DHD
- if DIASKHD'=""
- SET (X,DHD)=DIASKHD
- +3 QUIT