source: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPW21.m@ 1078

Last change on this file since 1078 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 7.6 KB
Line 
1SCRPW21 ;RENO/KEITH - ACRP Ad Hoc Report (cont.) ; 18 Nov 98 3:30 PM
2 ;;5.3;Scheduling;**144,166**;AUG 13, 1993
3BLD ;Build ^TMP global from data element parameters in file #409.92
4 ;Output: ^TMP global (where "str"=string obtained by $TEXT)
5 ; ^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
6 ; ^TMP("SCRPW",$J,"SEL",1,+$E($P(str,"~"),1,2),$P(str,"~",2))=major category external value~print field level
7 ; ^TMP("SCRPW",$J,"SEL",2,$P(str,"~",2),+$E($P(str,"~"),3,4),$P(str,"~",4))=minor category external value~print field level
8 N I,X,T S T="~"
9 S I=0 F S I=$O(^SD(409.92,I)) Q:'I S X=$$STR() D D BLD1
10 .F II=1:1:5,15 S X(II)=$P(X,T,II)
11 .Q
12 Q
13 ;
14BLD1 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
15 ;
16STR() ;Create parameter string
17 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))
18 Q X
19 ;
20SELT(SDPAR) ;Select/restore template
21 ;Required input: SDPAR to return parameter array (pass by reference)
22 ;Output: template ifn^template name - if successful, 0 otherwise
23 N DIC S DIC="^SDD(409.91,",DIC(0)="AEMQ" D ^DIC I $D(DTOUT)!$D(DUOUT) Q 0
24 Q:Y'>0 0 K SDPAR N SDI,SDII,SDIII,SDX,SDZ
25 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
26 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)=""
27 Q Y
28 ;
29SELT1 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)
30 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
31 Q
32 ;
33SELT2 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
34 ;
35SAVT(SDPAR) ;Save template
36 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
37 S DLAYGO=409.91,DIC="^SDD(409.91,",DIC(0)="AEMQL",DIC("A")="Save in ACRP REPORT TEMPLATE: "
38SAVT1 D ^DIC I $D(DTOUT)!$D(DUOUT)!($G(Y)<1) W ! Q
39 S SDNEW=+$P(Y,U,3) I 'SDNEW G:'$$SAVT0() SAVT1
40 S SDY=Y D:'SDNEW DELT
41 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
42 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
43 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
44 W !!,"...saved.",! Q
45 ;
46SAVT2 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
47 Q
48 ;
49SAVT3 S DA(2)=+SDY,DA(1)=+SDY1 D FILE^DICN S SDY2=Y
50 N SDZ,SDVAR S SDVAR(.02)=$P(SDPAR(SDX,SDX1),U),SDVAR(.03)=$P(SDPAR(SDX,SDX1),U,2)
51 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)
52 S DR="",SDZ=0 F S SDZ=$O(SDVAR(SDZ)) Q:'SDZ S DR=DR_";"_SDZ_"///^S X=SDVAR("_SDZ_")"
53 S DR=$E(DR,2,256),DIE=DIC,DA=+SDY2 D ^DIE
54 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
55 Q
56 ;
57SAVT4 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"
58 S DA(3)=+SDY,DA(2)=+SDY1,DA(1)=+SDY2 D FILE^DICN K DIC("DR")
59 Q
60 ;
61SAVT5 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
62 Q
63 ;
64SAVT6 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")
65 Q
66 ;
67SAVT0() W !!,"A template already exists by this name.",!
68 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
69 ;
70DELT ;Delete template parameters for write-over
71 N DIK,DA,SDI
72 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
73 Q
74 ;
75DATA(SDZ) ;Return data elements for Fileman function SCRPWDATA
76 ;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).
77 N X,SDOE,SDOE0,SDX
78 S X="",SDZ=$O(^SD(409.92,"C",SDZ,0)),SDZ=$G(^SD(409.92,+SDZ,11)) Q:'$L(SDZ) ""
79 S SDOE=D0,SDOE0=$$GETOE^SDOE(D0) Q:'$L(SDOE0) ""
80 I $P(SDOE0,U,6) S SDOE=$P(SDOE0,U,6),SDOE0=$$GETOE^SDOE(D0) Q:'$L(SDOE0) ""
81 X SDZ S (SDZ,SDX)="" F S SDX=$O(SDX(SDX)) Q:SDX="" S SDZ=SDZ_"; "_$P(SDX(SDX),U,2)
82 S SDZ=$E(SDZ,3,248) Q SDZ
83 ;
84PRTT ;Print from Ad Hoc template
85 D TITL^SCRPW50("Print from Ad Hoc Template")
86 I '$O(^SDD(409.91,0)) W !!,"No templates defined to print from!",! G END
87 W ! N SDPAR,%DT,X,Y G:'$$SELT(.SDPAR) END
88DTR D SUBT^SCRPW50("*** Date Range Selection ***")
89FDT W ! S %DT="AEPX",%DT("A")="Beginning date: " D ^%DT G:X=U!($D(DTOUT)) END G:X="" END
90 G:Y<1 FDT S SDPAR("L",1)=Y X ^DD("DD") S $P(SDPAR("L",1),U,2)=Y
91LDT W ! S %DT("A")=" Ending date: " D ^%DT G:X=U!($D(DTOUT)) END G:X="" END
92 I Y<$P(SDPAR("L",1),U) W !!,$C(7),"Ending date must be after beginning date!" G LDT
93 G:Y<1 LDT S SDPAR("L",2)=Y X ^DD("DD") S $P(SDPAR("L",2),U,2)=Y
94 W ! D QUE^SCRPW20,END Q
95 ;
96DIST ;Display template contents
97 D TITL^SCRPW50("Display Ad Hoc Report Template Parameters") N SDPAR,SDOUT,SDTEMP S SDTEMP=$$SELT(.SDPAR) G:'SDTEMP END
98 N ZTSAVE S ZTSAVE("SDPAR(")="",ZTSAVE("SDTEMP")="" W ! D EN^XUTMDEVQ("DISTP^SCRPW21","ACRP Ad Hoc Report Parameters",.ZTSAVE),END^SCRPW50,EXIT^SCRPW27 Q
99 ;
100DISTP N SDI S SDOUT=0,SDXY=^%ZOSF("XY") I $E(IOST)="C" W $$XY^SCRPW50(IOF,1,0)
101 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)
102 F SDI=3,5 D DATE(SDI)
103 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
104 G EXIT^SCRPW27
105 ;
106NAME(SDI) ;Get NEW PERSON name
107 S SDTEMP(SDI+1)=$S(SDI=2:"Created by^",1:"Last edited by^")_$P($G(^VA(200,+$P(SDTEMP,U,SDI),0)),U) Q
108 ;
109DATE(SDI) ;Get edited date
110 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
111 ;
112PURT ;Delete a template
113 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
114 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
115 N DIK S DIK=DIC D ^DIK W !,"...deleted." G END
116 ;
117END ;Clean up
118 D END^SCRPW50 Q
119 ;
120DFILE ;Delete file #409.92 entries prior to install
121 Q:'$D(^SD(409.92))
122 N DIK,DA S DIK="^SD(409.92,",DA=0
123 W !!,"Deleting file #409.92 entries"
124 F S DA=$O(^SD(409.92,DA)) Q:'DA D ^DIK W "."
125 W ! Q
Note: See TracBrowser for help on using the repository browser.