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