- SCRPW21 ;RENO/KEITH - ACRP Ad Hoc Report (cont.) ; 18 Nov 98 3:30 PM
- ;;5.3;Scheduling;**144,166**;AUG 13, 1993
- BLD ;Build ^TMP global from data element parameters in file #409.92
- ;Output: ^TMP global (where "str"=string obtained by $TEXT)
- ; ^TMP("SCRPW",$J,"ACT",$P(str,"~",2)_$P(str,"~",4))=minor category external value~type~type where~type screen~choice method~number of choices~code to set SDX
- ; ^TMP("SCRPW",$J,"SEL",1,+$E($P(str,"~"),1,2),$P(str,"~",2))=major category external value~print field level
- ; ^TMP("SCRPW",$J,"SEL",2,$P(str,"~",2),+$E($P(str,"~"),3,4),$P(str,"~",4))=minor category external value~print field level
- N I,X,T S T="~"
- S I=0 F S I=$O(^SD(409.92,I)) Q:'I S X=$$STR() D D BLD1
- .F II=1:1:5,15 S X(II)=$P(X,T,II)
- .Q
- Q
- ;
- BLD1 S ^TMP("SCRPW",$J,"SEL",1,+$E(X(1),1,2),X(2))=X(3)_T_X(15),^TMP("SCRPW",$J,"SEL",2,X(2),+$E(X(1),3,4),X(4))=X(5)_T_X(15),^TMP("SCRPW",$J,"ACT",X(2)_X(4))=$P(X,T,5,20) Q
- ;
- STR() ;Create parameter string
- N X,II S X=^SD(409.92,I,0),X=$TR(X,"^","~") F II=7,8,11,12,13 S $P(X,"~",II)=$G(^SD(409.92,I,II))
- Q X
- ;
- SELT(SDPAR) ;Select/restore template
- ;Required input: SDPAR to return parameter array (pass by reference)
- ;Output: template ifn^template name - if successful, 0 otherwise
- N DIC S DIC="^SDD(409.91,",DIC(0)="AEMQ" D ^DIC I $D(DTOUT)!$D(DUOUT) Q 0
- Q:Y'>0 0 K SDPAR N SDI,SDII,SDIII,SDX,SDZ
- S SDI=0 F S SDI=$O(^SDD(409.91,+Y,1,SDI)) Q:'SDI S SDX=$P(^SDD(409.91,+Y,1,SDI,0),U) S SDII=0 F S SDII=$O(^SDD(409.91,+Y,1,SDI,1,SDII)) Q:'SDII S SDPAR(SDX,SDII)=$P(^SDD(409.91,+Y,1,SDI,1,SDII,0),U,2,3) D SELT1
- S SDI=0 F S SDI=$O(^SDD(409.91,+Y,2,SDI)) Q:'SDI S SDII=0 F S SDII=$O(^SDD(409.91,+Y,2,SDI,1,SDII)) Q:'SDII S SDX=^SDD(409.91,+Y,2,SDI,1,SDII,0),SDPAR("PF",SDI,SDII)=SDX,SDPAR("PFX",$P(SDX,U),SDI,SDII)=""
- Q Y
- ;
- SELT1 F SDIII=1,2,3,6 S:$D(^SDD(409.91,+Y,1,SDI,1,SDII,SDIII)) SDPAR(SDX,SDII,SDIII)=$P(^SDD(409.91,+Y,1,SDI,1,SDII,SDIII),U,1,2)
- S SDIII=0 F S SDIII=$O(^SDD(409.91,+Y,1,SDI,1,SDII,4,SDIII)) Q:'SDIII S SDZ=^SDD(409.91,+Y,1,SDI,1,SDII,4,SDIII,0) D SELT2
- Q
- ;
- SELT2 S SDPAR($P(SDX,U),SDII,4,$P(SDZ,U),$P(SDZ,U,2))="",SDPAR($P(SDX,U),SDII,5,$P(SDZ,U,2))=$P(SDZ,U) Q
- ;
- SAVT(SDPAR) ;Save template
- Q:'$D(^XUSEC("SC AD HOC TEMPLATE",DUZ)) N DLAYGO,DIC,DIE,DR,DA,X,DD,DO,SDY,SDY1,SDY2,SDX,SDX1,SDX2,SDX3,SDZ,SDI,SDII,SDIII
- S DLAYGO=409.91,DIC="^SDD(409.91,",DIC(0)="AEMQL",DIC("A")="Save in ACRP REPORT TEMPLATE: "
- SAVT1 D ^DIC I $D(DTOUT)!$D(DUOUT)!($G(Y)<1) W ! Q
- S SDNEW=+$P(Y,U,3) I 'SDNEW G:'$$SAVT0() SAVT1
- S SDY=Y D:'SDNEW DELT
- S DIE="^SDD(409.91,",DA=+SDY,DR=$S(SDNEW:"1////^S X=DUZ;2///NOW;",1:"")_"3////^S X=DUZ;4///NOW;5" D ^DIE
- F SDX="F","P","L","O" K DD,DO S DA(1)=+SDY,DIC="^SDD(409.91,"_+SDY_",1,",X=SDX,DLAYGO=409.916 D FIELD^DID(409.91,6,,"SPECIFIER","SDF") S DIC("P")=SDF("SPECIFIER") D FILE^DICN S SDY1=Y D SAVT2
- S SDX=0 F S SDX=$O(SDPAR("PF",SDX)) Q:'SDX K DD,DO S DIC="^SDD(409.91,"_+SDY_",2,",DLAYGO=409.917,(DINUM,X)=SDX D FIELD^DID(409.91,7,,"SPECIFIER","SDF") S DIC("P")=SDF("SPECIFIER") D FILE^DICN S SDY1=Y D SAVT5
- W !!,"...saved.",! Q
- ;
- SAVT2 S SDX1="" F S SDX1=$O(SDPAR(SDX,SDX1)) Q:'SDX1 K DD,DO S (X,DINUM)=SDX1,DLAYGO=409.9161,DIC="^SDD(409.91,"_+SDY_",1,"_+SDY1_",1," D FIELD^DID(409.916,1,,"SPECIFIER","SDF") S DIC("P")=SDF("SPECIFIER") D SAVT3
- Q
- ;
- SAVT3 S DA(2)=+SDY,DA(1)=+SDY1 D FILE^DICN S SDY2=Y
- N SDZ,SDVAR S SDVAR(.02)=$P(SDPAR(SDX,SDX1),U),SDVAR(.03)=$P(SDPAR(SDX,SDX1),U,2)
- F SDX2=1,2,3,6 I $D(SDPAR(SDX,SDX1,SDX2)) S SDZ=SDPAR(SDX,SDX1,SDX2),SDVAR(SDX2)=$P(SDZ,U) S:$L($P(SDZ,U,2)) SDVAR((SDX2_".1"))=$P(SDZ,U,2)
- S DR="",SDZ=0 F S SDZ=$O(SDVAR(SDZ)) Q:'SDZ S DR=DR_";"_SDZ_"///^S X=SDVAR("_SDZ_")"
- S DR=$E(DR,2,256),DIE=DIC,DA=+SDY2 D ^DIE
- S SDX2="" F S SDX2=$O(SDPAR(SDX,SDX1,4,SDX2)) Q:SDX2="" S SDX3="" F S SDX3=$O(SDPAR(SDX,SDX1,4,SDX2,SDX3)) Q:SDX3="" D SAVT4
- Q
- ;
- SAVT4 K DD,DO S X=SDX2,DLAYGO=409.91614,DIC="^SDD(409.91,"_+SDY_",1,"_+SDY1_",1,"_+SDY2_",4," D FIELD^DID(409.9161,4,,"SPECIFIER","SDF") S DIC("P")=SDF("SPECIFIER"),DIC("DR")=".02///^S X=SDX3"
- S DA(3)=+SDY,DA(2)=+SDY1,DA(1)=+SDY2 D FILE^DICN K DIC("DR")
- Q
- ;
- SAVT5 S SDX1=0 F S SDX1=$O(SDPAR("PF",SDX,SDX1)) Q:'SDX1 K DD,DO S DIC="^SDD(409.91,"_+SDY_",2,"_+SDY1_",1,",DLAYGO=409.9171,DINUM=SDX1 D FIELD^DID(409.917,1,,"SPECIFIER","SDF") S DIC("P")=SDF("SPECIFIER") D SAVT6
- Q
- ;
- SAVT6 S SDZ=SDPAR("PF",SDX,SDX1),X=$P(SDZ,U),SDZ(2)=$P(SDZ,U,2),SDZ(3)=$P(SDZ,U,3),DIC("DR")="1///^S X=SDZ(2);2///^S X=SDZ(3)",DA(2)=+SDY,DA(1)=+SDY1 D FILE^DICN K DIC("DR")
- Q
- ;
- SAVT0() W !!,"A template already exists by this name.",!
- N DIR,Y S DIR(0)="Y",DIR("A")="Do you wish to write over the existing template",DIR("B")="NO" D ^DIR Q:$D(DTOUT)!$D(DUOUT) 0 Q Y
- ;
- DELT ;Delete template parameters for write-over
- N DIK,DA,SDI
- F SDI=1,2 S DA(1)=+SDY,DA=0 F S DA=$O(^SDD(409.91,DA(1),SDI,DA)) Q:'DA S DIK="^SDD(409.91,"_DA(1)_","_SDI_"," D ^DIK
- Q
- ;
- DATA(SDZ) ;Return data elements for Fileman function SCRPWDATA
- ;Required input: SDZ=data element (this can be any ACRONYM or MINOR CATEGORY (EXTERNAL) value found in file #409.92--must be in the 'C' x-ref. of this file).
- N X,SDOE,SDOE0,SDX
- S X="",SDZ=$O(^SD(409.92,"C",SDZ,0)),SDZ=$G(^SD(409.92,+SDZ,11)) Q:'$L(SDZ) ""
- S SDOE=D0,SDOE0=$$GETOE^SDOE(D0) Q:'$L(SDOE0) ""
- I $P(SDOE0,U,6) S SDOE=$P(SDOE0,U,6),SDOE0=$$GETOE^SDOE(D0) Q:'$L(SDOE0) ""
- X SDZ S (SDZ,SDX)="" F S SDX=$O(SDX(SDX)) Q:SDX="" S SDZ=SDZ_"; "_$P(SDX(SDX),U,2)
- S SDZ=$E(SDZ,3,248) Q SDZ
- ;
- PRTT ;Print from Ad Hoc template
- D TITL^SCRPW50("Print from Ad Hoc Template")
- I '$O(^SDD(409.91,0)) W !!,"No templates defined to print from!",! G END
- W ! N SDPAR,%DT,X,Y G:'$$SELT(.SDPAR) END
- DTR D SUBT^SCRPW50("*** Date Range Selection ***")
- FDT W ! S %DT="AEPX",%DT("A")="Beginning date: " D ^%DT G:X=U!($D(DTOUT)) END G:X="" END
- G:Y<1 FDT S SDPAR("L",1)=Y X ^DD("DD") S $P(SDPAR("L",1),U,2)=Y
- LDT W ! S %DT("A")=" Ending date: " D ^%DT G:X=U!($D(DTOUT)) END G:X="" END
- I Y<$P(SDPAR("L",1),U) W !!,$C(7),"Ending date must be after beginning date!" G LDT
- G:Y<1 LDT S SDPAR("L",2)=Y X ^DD("DD") S $P(SDPAR("L",2),U,2)=Y
- W ! D QUE^SCRPW20,END Q
- ;
- DIST ;Display template contents
- D TITL^SCRPW50("Display Ad Hoc Report Template Parameters") N SDPAR,SDOUT,SDTEMP S SDTEMP=$$SELT(.SDPAR) G:'SDTEMP END
- N ZTSAVE S ZTSAVE("SDPAR(")="",ZTSAVE("SDTEMP")="" W ! D EN^XUTMDEVQ("DISTP^SCRPW21","ACRP Ad Hoc Report Parameters",.ZTSAVE),END^SCRPW50,EXIT^SCRPW27 Q
- ;
- DISTP N SDI S SDOUT=0,SDXY=^%ZOSF("XY") I $E(IOST)="C" W $$XY^SCRPW50(IOF,1,0)
- S SDTEMP=^SDD(409.91,+SDTEMP,0),SDTEMP(1)="Name^"_$P(SDTEMP,U,1),SDTEMP(2)="Description^"_$P(SDTEMP,U,6) F SDI=2,4 D NAME(SDI)
- F SDI=3,5 D DATE(SDI)
- D:$E(IOST)'="C" HDR^SCRPW29("Report Parameters Selected") G:SDOUT EXIT^SCRPW27 D PLIST^SCRPW22((IOM-80\2),$S($E(IOST)="C":(IOSL-3),1:(IOSL-10)),.SDTEMP) Q
- G EXIT^SCRPW27
- ;
- NAME(SDI) ;Get NEW PERSON name
- S SDTEMP(SDI+1)=$S(SDI=2:"Created by^",1:"Last edited by^")_$P($G(^VA(200,+$P(SDTEMP,U,SDI),0)),U) Q
- ;
- DATE(SDI) ;Get edited date
- S Y=$P(SDTEMP,U,SDI) I Y X ^DD("DD") S SDTEMP(SDI+1)="Date "_$S(SDI=3:"created^",1:"last edited^")_Y Q
- ;
- PURT ;Delete a template
- D TITL^SCRPW50("Delete an Ad Hoc Report Template") N DIC,DA,X,Y S DIC="^SDD(409.91,",DIC(0)="AEMQ" W ! D ^DIC G:$D(DTOUT)!$D(DUOUT) END G:Y<1 END S DA=+Y
- N DIR S DIR(0)="Y",DIR("A")="Are you sure you want to delete this 'ACRP Ad Hoc Report' template",DIR("B")="NO" W ! D ^DIR G:$D(DTOUT)!$D(DUOUT) END G:Y<1 END
- N DIK S DIK=DIC D ^DIK W !,"...deleted." G END
- ;
- END ;Clean up
- D END^SCRPW50 Q
- ;
- DFILE ;Delete file #409.92 entries prior to install
- Q:'$D(^SD(409.92))
- N DIK,DA S DIK="^SD(409.92,",DA=0
- W !!,"Deleting file #409.92 entries"
- F S DA=$O(^SD(409.92,DA)) Q:'DA D ^DIK W "."
- W ! Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCRPW21 7858 printed Jan 18, 2025@03:44:33 Page 2
- SCRPW21 ;RENO/KEITH - ACRP Ad Hoc Report (cont.) ; 18 Nov 98 3:30 PM
- +1 ;;5.3;Scheduling;**144,166**;AUG 13, 1993
- BLD ;Build ^TMP global from data element parameters in file #409.92
- +1 ;Output: ^TMP global (where "str"=string obtained by $TEXT)
- +2 ; ^TMP("SCRPW",$J,"ACT",$P(str,"~",2)_$P(str,"~",4))=minor category external value~type~type where~type screen~choice method~number of choices~code to set SDX
- +3 ; ^TMP("SCRPW",$J,"SEL",1,+$E($P(str,"~"),1,2),$P(str,"~",2))=major category external value~print field level
- +4 ; ^TMP("SCRPW",$J,"SEL",2,$P(str,"~",2),+$E($P(str,"~"),3,4),$P(str,"~",4))=minor category external value~print field level
- +5 NEW I,X,T
- SET T="~"
- +6 SET I=0
- FOR
- SET I=$ORDER(^SD(409.92,I))
- if 'I
- QUIT
- SET X=$$STR()
- Begin DoDot:1
- +7 FOR II=1:1:5,15
- SET X(II)=$PIECE(X,T,II)
- +8 QUIT
- End DoDot:1
- DO BLD1
- +9 QUIT
- +10 ;
- BLD1 SET ^TMP("SCRPW",$JOB,"SEL",1,+$EXTRACT(X(1),1,2),X(2))=X(3)_T_X(15)
- SET ^TMP("SCRPW",$JOB,"SEL",2,X(2),+$EXTRACT(X(1),3,4),X(4))=X(5)_T_X(15)
- SET ^TMP("SCRPW",$JOB,"ACT",X(2)_X(4))=$PIECE(X,T,5,20)
- QUIT
- +1 ;
- STR() ;Create parameter string
- +1 NEW X,II
- SET X=^SD(409.92,I,0)
- SET X=$TRANSLATE(X,"^","~")
- FOR II=7,8,11,12,13
- SET $PIECE(X,"~",II)=$GET(^SD(409.92,I,II))
- +2 QUIT X
- +3 ;
- SELT(SDPAR) ;Select/restore template
- +1 ;Required input: SDPAR to return parameter array (pass by reference)
- +2 ;Output: template ifn^template name - if successful, 0 otherwise
- +3 NEW DIC
- SET DIC="^SDD(409.91,"
- SET DIC(0)="AEMQ"
- DO ^DIC
- IF $DATA(DTOUT)!$DATA(DUOUT)
- QUIT 0
- +4 if Y'>0
- QUIT 0
- KILL SDPAR
- NEW SDI,SDII,SDIII,SDX,SDZ
- +5 SET SDI=0
- FOR
- SET SDI=$ORDER(^SDD(409.91,+Y,1,SDI))
- if 'SDI
- QUIT
- SET SDX=$PIECE(^SDD(409.91,+Y,1,SDI,0),U)
- SET SDII=0
- FOR
- SET SDII=$ORDER(^SDD(409.91,+Y,1,SDI,1,SDII))
- if 'SDII
- QUIT
- SET SDPAR(SDX,SDII)=$PIECE(^SDD(409.91,+Y,1,SDI,1,SDII,0),U,2,3)
- DO SELT1
- +6 SET SDI=0
- FOR
- SET SDI=$ORDER(^SDD(409.91,+Y,2,SDI))
- if 'SDI
- QUIT
- SET SDII=0
- FOR
- SET SDII=$ORDER(^SDD(409.91,+Y,2,SDI,1,SDII))
- if 'SDII
- QUIT
- SET SDX=^SDD(409.91,+Y,2,SDI,1,SDII,0)
- SET SDPAR("PF",SDI,SDII)=SDX
- SET SDPAR("PFX",$PIECE(SDX,U),SDI,SDII)=""
- +7 QUIT Y
- +8 ;
- SELT1 FOR SDIII=1,2,3,6
- if $DATA(^SDD(409.91,+Y,1,SDI,1,SDII,SDIII))
- SET SDPAR(SDX,SDII,SDIII)=$PIECE(^SDD(409.91,+Y,1,SDI,1,SDII,SDIII),U,1,2)
- +1 SET SDIII=0
- FOR
- SET SDIII=$ORDER(^SDD(409.91,+Y,1,SDI,1,SDII,4,SDIII))
- if 'SDIII
- QUIT
- SET SDZ=^SDD(409.91,+Y,1,SDI,1,SDII,4,SDIII,0)
- DO SELT2
- +2 QUIT
- +3 ;
- SELT2 SET SDPAR($PIECE(SDX,U),SDII,4,$PIECE(SDZ,U),$PIECE(SDZ,U,2))=""
- SET SDPAR($PIECE(SDX,U),SDII,5,$PIECE(SDZ,U,2))=$PIECE(SDZ,U)
- QUIT
- +1 ;
- SAVT(SDPAR) ;Save template
- +1 if '$DATA(^XUSEC("SC AD HOC TEMPLATE",DUZ))
- QUIT
- NEW DLAYGO,DIC,DIE,DR,DA,X,DD,DO,SDY,SDY1,SDY2,SDX,SDX1,SDX2,SDX3,SDZ,SDI,SDII,SDIII
- +2 SET DLAYGO=409.91
- SET DIC="^SDD(409.91,"
- SET DIC(0)="AEMQL"
- SET DIC("A")="Save in ACRP REPORT TEMPLATE: "
- SAVT1 DO ^DIC
- IF $DATA(DTOUT)!$DATA(DUOUT)!($GET(Y)<1)
- WRITE !
- QUIT
- +1 SET SDNEW=+$PIECE(Y,U,3)
- IF 'SDNEW
- if '$$SAVT0()
- GOTO SAVT1
- +2 SET SDY=Y
- if 'SDNEW
- DO DELT
- +3 SET DIE="^SDD(409.91,"
- SET DA=+SDY
- SET DR=$SELECT(SDNEW:"1////^S X=DUZ;2///NOW;",1:"")_"3////^S X=DUZ;4///NOW;5"
- DO ^DIE
- +4 FOR SDX="F","P","L","O"
- KILL DD,DO
- SET DA(1)=+SDY
- SET DIC="^SDD(409.91,"_+SDY_",1,"
- SET X=SDX
- SET DLAYGO=409.916
- DO FIELD^DID(409.91,6,,"SPECIFIER","SDF")
- SET DIC("P")=SDF("SPECIFIER")
- DO FILE^DICN
- SET SDY1=Y
- DO SAVT2
- +5 SET SDX=0
- FOR
- SET SDX=$ORDER(SDPAR("PF",SDX))
- if 'SDX
- QUIT
- KILL DD,DO
- SET DIC="^SDD(409.91,"_+SDY_",2,"
- SET DLAYGO=409.917
- SET (DINUM,X)=SDX
- DO FIELD^DID(409.91,7,,"SPECIFIER","SDF")
- SET DIC("P")=SDF("SPECIFIER")
- DO FILE^DICN
- SET SDY1=Y
- DO SAVT5
- +6 WRITE !!,"...saved.",!
- QUIT
- +7 ;
- SAVT2 SET SDX1=""
- FOR
- SET SDX1=$ORDER(SDPAR(SDX,SDX1))
- if 'SDX1
- QUIT
- KILL DD,DO
- SET (X,DINUM)=SDX1
- SET DLAYGO=409.9161
- SET DIC="^SDD(409.91,"_+SDY_",1,"_+SDY1_",1,"
- DO FIELD^DID(409.916,1,,"SPECIFIER","SDF")
- SET DIC("P")=SDF("SPECIFIER")
- DO SAVT3
- +1 QUIT
- +2 ;
- SAVT3 SET DA(2)=+SDY
- SET DA(1)=+SDY1
- DO FILE^DICN
- SET SDY2=Y
- +1 NEW SDZ,SDVAR
- SET SDVAR(.02)=$PIECE(SDPAR(SDX,SDX1),U)
- SET SDVAR(.03)=$PIECE(SDPAR(SDX,SDX1),U,2)
- +2 FOR SDX2=1,2,3,6
- IF $DATA(SDPAR(SDX,SDX1,SDX2))
- SET SDZ=SDPAR(SDX,SDX1,SDX2)
- SET SDVAR(SDX2)=$PIECE(SDZ,U)
- if $LENGTH($PIECE(SDZ,U,2))
- SET SDVAR((SDX2_".1"))=$PIECE(SDZ,U,2)
- +3 SET DR=""
- SET SDZ=0
- FOR
- SET SDZ=$ORDER(SDVAR(SDZ))
- if 'SDZ
- QUIT
- SET DR=DR_";"_SDZ_"///^S X=SDVAR("_SDZ_")"
- +4 SET DR=$EXTRACT(DR,2,256)
- SET DIE=DIC
- SET DA=+SDY2
- DO ^DIE
- +5 SET SDX2=""
- FOR
- SET SDX2=$ORDER(SDPAR(SDX,SDX1,4,SDX2))
- if SDX2=""
- QUIT
- SET SDX3=""
- FOR
- SET SDX3=$ORDER(SDPAR(SDX,SDX1,4,SDX2,SDX3))
- if SDX3=""
- QUIT
- DO SAVT4
- +6 QUIT
- +7 ;
- SAVT4 KILL DD,DO
- SET X=SDX2
- SET DLAYGO=409.91614
- SET DIC="^SDD(409.91,"_+SDY_",1,"_+SDY1_",1,"_+SDY2_",4,"
- DO FIELD^DID(409.9161,4,,"SPECIFIER","SDF")
- SET DIC("P")=SDF("SPECIFIER")
- SET DIC("DR")=".02///^S X=SDX3"
- +1 SET DA(3)=+SDY
- SET DA(2)=+SDY1
- SET DA(1)=+SDY2
- DO FILE^DICN
- KILL DIC("DR")
- +2 QUIT
- +3 ;
- SAVT5 SET SDX1=0
- FOR
- SET SDX1=$ORDER(SDPAR("PF",SDX,SDX1))
- if 'SDX1
- QUIT
- KILL DD,DO
- SET DIC="^SDD(409.91,"_+SDY_",2,"_+SDY1_",1,"
- SET DLAYGO=409.9171
- SET DINUM=SDX1
- DO FIELD^DID(409.917,1,,"SPECIFIER","SDF")
- SET DIC("P")=SDF("SPECIFIER")
- DO SAVT6
- +1 QUIT
- +2 ;
- SAVT6 SET SDZ=SDPAR("PF",SDX,SDX1)
- SET X=$PIECE(SDZ,U)
- SET SDZ(2)=$PIECE(SDZ,U,2)
- SET SDZ(3)=$PIECE(SDZ,U,3)
- SET DIC("DR")="1///^S X=SDZ(2);2///^S X=SDZ(3)"
- SET DA(2)=+SDY
- SET DA(1)=+SDY1
- DO FILE^DICN
- KILL DIC("DR")
- +1 QUIT
- +2 ;
- SAVT0() WRITE !!,"A template already exists by this name.",!
- +1 NEW DIR,Y
- SET DIR(0)="Y"
- SET DIR("A")="Do you wish to write over the existing template"
- SET DIR("B")="NO"
- DO ^DIR
- if $DATA(DTOUT)!$DATA(DUOUT)
- QUIT 0
- QUIT Y
- +2 ;
- DELT ;Delete template parameters for write-over
- +1 NEW DIK,DA,SDI
- +2 FOR SDI=1,2
- SET DA(1)=+SDY
- SET DA=0
- FOR
- SET DA=$ORDER(^SDD(409.91,DA(1),SDI,DA))
- if 'DA
- QUIT
- SET DIK="^SDD(409.91,"_DA(1)_","_SDI_","
- DO ^DIK
- +3 QUIT
- +4 ;
- DATA(SDZ) ;Return data elements for Fileman function SCRPWDATA
- +1 ;Required input: SDZ=data element (this can be any ACRONYM or MINOR CATEGORY (EXTERNAL) value found in file #409.92--must be in the 'C' x-ref. of this file).
- +2 NEW X,SDOE,SDOE0,SDX
- +3 SET X=""
- SET SDZ=$ORDER(^SD(409.92,"C",SDZ,0))
- SET SDZ=$GET(^SD(409.92,+SDZ,11))
- if '$LENGTH(SDZ)
- QUIT ""
- +4 SET SDOE=D0
- SET SDOE0=$$GETOE^SDOE(D0)
- if '$LENGTH(SDOE0)
- QUIT ""
- +5 IF $PIECE(SDOE0,U,6)
- SET SDOE=$PIECE(SDOE0,U,6)
- SET SDOE0=$$GETOE^SDOE(D0)
- if '$LENGTH(SDOE0)
- QUIT ""
- +6 XECUTE SDZ
- SET (SDZ,SDX)=""
- FOR
- SET SDX=$ORDER(SDX(SDX))
- if SDX=""
- QUIT
- SET SDZ=SDZ_"; "_$PIECE(SDX(SDX),U,2)
- +7 SET SDZ=$EXTRACT(SDZ,3,248)
- QUIT SDZ
- +8 ;
- PRTT ;Print from Ad Hoc template
- +1 DO TITL^SCRPW50("Print from Ad Hoc Template")
- +2 IF '$ORDER(^SDD(409.91,0))
- WRITE !!,"No templates defined to print from!",!
- GOTO END
- +3 WRITE !
- NEW SDPAR,%DT,X,Y
- if '$$SELT(.SDPAR)
- GOTO END
- DTR DO SUBT^SCRPW50("*** Date Range Selection ***")
- FDT WRITE !
- SET %DT="AEPX"
- SET %DT("A")="Beginning date: "
- DO ^%DT
- if X=U!($DATA(DTOUT))
- GOTO END
- if X=""
- GOTO END
- +1 if Y<1
- GOTO FDT
- SET SDPAR("L",1)=Y
- XECUTE ^DD("DD")
- SET $PIECE(SDPAR("L",1),U,2)=Y
- LDT WRITE !
- SET %DT("A")=" Ending date: "
- DO ^%DT
- if X=U!($DATA(DTOUT))
- GOTO END
- if X=""
- GOTO END
- +1 IF Y<$PIECE(SDPAR("L",1),U)
- WRITE !!,$CHAR(7),"Ending date must be after beginning date!"
- GOTO LDT
- +2 if Y<1
- GOTO LDT
- SET SDPAR("L",2)=Y
- XECUTE ^DD("DD")
- SET $PIECE(SDPAR("L",2),U,2)=Y
- +3 WRITE !
- DO QUE^SCRPW20
- DO END
- QUIT
- +4 ;
- DIST ;Display template contents
- +1 DO TITL^SCRPW50("Display Ad Hoc Report Template Parameters")
- NEW SDPAR,SDOUT,SDTEMP
- SET SDTEMP=$$SELT(.SDPAR)
- if 'SDTEMP
- GOTO END
- +2 NEW ZTSAVE
- SET ZTSAVE("SDPAR(")=""
- SET ZTSAVE("SDTEMP")=""
- WRITE !
- DO EN^XUTMDEVQ("DISTP^SCRPW21","ACRP Ad Hoc Report Parameters",.ZTSAVE)
- DO END^SCRPW50
- DO EXIT^SCRPW27
- QUIT
- +3 ;
- DISTP NEW SDI
- SET SDOUT=0
- SET SDXY=^%ZOSF("XY")
- IF $EXTRACT(IOST)="C"
- WRITE $$XY^SCRPW50(IOF,1,0)
- +1 SET SDTEMP=^SDD(409.91,+SDTEMP,0)
- SET SDTEMP(1)="Name^"_$PIECE(SDTEMP,U,1)
- SET SDTEMP(2)="Description^"_$PIECE(SDTEMP,U,6)
- FOR SDI=2,4
- DO NAME(SDI)
- +2 FOR SDI=3,5
- DO DATE(SDI)
- +3 if $EXTRACT(IOST)'="C"
- DO HDR^SCRPW29("Report Parameters Selected")
- if SDOUT
- GOTO EXIT^SCRPW27
- DO PLIST^SCRPW22((IOM-80\2),$SELECT($EXTRACT(IOST)="C":(IOSL-3),1:(IOSL-10)),.SDTEMP)
- QUIT
- +4 GOTO EXIT^SCRPW27
- +5 ;
- NAME(SDI) ;Get NEW PERSON name
- +1 SET SDTEMP(SDI+1)=$SELECT(SDI=2:"Created by^",1:"Last edited by^")_$PIECE($GET(^VA(200,+$PIECE(SDTEMP,U,SDI),0)),U)
- QUIT
- +2 ;
- DATE(SDI) ;Get edited date
- +1 SET Y=$PIECE(SDTEMP,U,SDI)
- IF Y
- XECUTE ^DD("DD")
- SET SDTEMP(SDI+1)="Date "_$SELECT(SDI=3:"created^",1:"last edited^")_Y
- QUIT
- +2 ;
- PURT ;Delete a template
- +1 DO TITL^SCRPW50("Delete an Ad Hoc Report Template")
- NEW DIC,DA,X,Y
- SET DIC="^SDD(409.91,"
- SET DIC(0)="AEMQ"
- WRITE !
- DO ^DIC
- if $DATA(DTOUT)!$DATA(DUOUT)
- GOTO END
- if Y<1
- GOTO END
- SET DA=+Y
- +2 NEW DIR
- SET DIR(0)="Y"
- SET DIR("A")="Are you sure you want to delete this 'ACRP Ad Hoc Report' template"
- SET DIR("B")="NO"
- WRITE !
- DO ^DIR
- if $DATA(DTOUT)!$DATA(DUOUT)
- GOTO END
- if Y<1
- GOTO END
- +3 NEW DIK
- SET DIK=DIC
- DO ^DIK
- WRITE !,"...deleted."
- GOTO END
- +4 ;
- END ;Clean up
- +1 DO END^SCRPW50
- QUIT
- +2 ;
- DFILE ;Delete file #409.92 entries prior to install
- +1 if '$DATA(^SD(409.92))
- QUIT
- +2 NEW DIK,DA
- SET DIK="^SD(409.92,"
- SET DA=0
- +3 WRITE !!,"Deleting file #409.92 entries"
- +4 FOR
- SET DA=$ORDER(^SD(409.92,DA))
- if 'DA
- QUIT
- DO ^DIK
- WRITE "."
- +5 WRITE !
- QUIT