SCRPW21 ;RENO/KEITH - ACRP Ad Hoc Report (cont.) ; 18 Nov 98 3:30 PM
;;5.3;Scheduling;**144,166,1015**;AUG 13, 1993;Build 21
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
SCRPW21 ;RENO/KEITH - ACRP Ad Hoc Report (cont.) ; 18 Nov 98 3:30 PM
+1 ;;5.3;Scheduling;**144,166,1015**;AUG 13, 1993;Build 21
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
