source: WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOTPCL.m@ 1520

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

initial load of WorldVistAEHR

File size: 4.0 KB
Line 
1PSOTPCL ;BIRM/PDW-EDIT TPC INSTITUTION LETTERS
2 ;;7.0;OUTPATIENT PHARMACY;**145,227**;DEC 1997
3 Q
4EDIT ; Manual edit of institution letter information in 52.92
5 Q ;placed out of order by patch PSO*7*227
6 W @IOF
7 W !," Transitional Pharmacy Care"
8 W !," Edit Institution Letter Information"
9EDIT2 W !!,"(You may add a NEW Institution at this point.)",!
10 D PSTINT
11 K DIC,DA
12 S DIC=52.92,DIC(0)="AEQML",DIC("W")="W ?40,$$GET1^DIQ(52.92,+Y,.02) W:$$CHKINST^PSOTPCL(+Y) ?69,"" Incomp""",DIC("A")="Select/Add TPB INSTITUTION: ",DLAYGO=52.92
13 D ^DIC K DLAYGO
14 G:Y'>0 EXIT
15 S DA=+Y,DR="[INSTITUTION EDIT]",DDSFILE=52.92
16 D ^DDS
17 G EDIT2
18 ;
19EXIT K DIC,DIE,DR,DDSFILE
20 W @IOF
21 Q
22PSTINT ;Take institution entries from 52.91 & stuff into 52.92
23 S LOCDA=0 F S LOCDA=$O(^PS(52.91,"AC",LOCDA)) Q:LOCDA'>0 D LOCDA
24 Q
25LOCDA ;Get physical and mailing address
26 I $D(^PS(52.92,LOCDA,0)) Q
27 N FAC,FDA
28 ; set FAC(FLD#)=(INTvalue of FLD#); ex: FAC(.01)=500 :"Birmingham VAMC"
29 ;
30 F XX=.01,.02,1.01,1.02,1.03,1.04 S FAC(XX)=$$GET1^DIQ(4,LOCDA,XX,"I")
31 F XX=4.01,4.02,4.03,4.04,4.05 S FAC(XX)=$$GET1^DIQ(4,LOCDA,XX,"I")
32 ;
33 ; build/map fields from iNSTITUTION file to TPB INSTITUTION LETTER
34 ; file into FDA
35 ; "XFDL^YFLD," stuff XFLD of file 52.92 with YFLD of file 4
36 ;
37 F XX=".01^.01",".05^1.01",".06^1.02",".07^1.03",".08^1.04",".09^.02","1.01^4.01","1.02^4.02","1.03^4.03","1.04^4.04","1.05^4.05" D
38 . S XFLD=+XX,YFLD=$P(XX,U,2)
39 . S FDA(52.92,"+1,",XFLD)=FAC(YFLD)
40 S FDA(52.92,"+1,",.01)=LOCDA,LOCDA(1)=LOCDA
41 D UPDATE^DIE("","FDA","LOCDA","MSG")
42 Q
43SEL ;Select divisions
44 ; returns arrays
45 ; for testing
46 W !!,"SELECTION OF INSTITUTION(S)",!
47 K DIVNM,DIVDA,DIVX
48 S DIVDA=0 F I=1:1 S DIVDA=$O(^PS(52.92,"B",DIVDA)) Q:DIVDA'>0 D
49 . Q:$$CHKINST(DIVDA) ; only completed institutions
50 . S DIV=$$GET1^DIQ(52.92,DIVDA,.01) S INST(DIVDA)=DIV
51 K DIR S DIR(0)="S^A:ALL INSTITUTIONS;S:SELECT INSTITUTIONS"
52 D ^DIR K DIR
53 G:Y="A" ALL
54 G:Y="S" SELECT
55 K INST
56 Q
57SELECT ; select range of divisioins
58 K INST,DIC
59 S DIC="^PS(52.92,",DIC(0)="AEQM"
60 F S DIC("W")="W ?40,$E($$GET1^DIQ(52.92,+Y,.02),1,18) I $$CHKINST^PSOTPCL(+Y) W ?60,""Incomplete""" D ^DIC Q:Y'>0 D
61 . I $$CHKINST(+Y) W !,"Sorry, data for that institution is incomplete",! Q
62 . S INST(+Y)=$$GET1^DIQ(52.92,+Y,.01)
63ALL K PSOSTOP
64 I '$D(INST) S INST="" W !,"None Selected - Quitting",! H 3 Q
65 W !!,"You have selected:",! S DIV=0 F II=1:1 D:'(II#18) PG Q:$G(PSOSTOP) S DIV=$O(INST(DIV)) Q:'DIV W !,?5,INST(DIV)
66 S DIR(0)="Y",DIR("A")="Is this correct ",DIR("B")="YES" D ^DIR
67 K DIR
68 Q:Y
69 G SEL
70 ;
71PG K DIR S DIR(0)="E",DIR("A")="CR - CONTINUE ^ - Quit" D ^DIR
72 S:X["^" PSOSTOP=1
73 Q
74INSTCHK() ; check required fields of INST in the array INST(INSTDA)
75 N FAC S FAC=0
76 S INSTDA=0 F S INSTDA=$O(INST(INSTDA)) Q:INSTDA'>0 S XX=$$CHKINST(INSTDA) I $L(XX) W !,"Sorry, required field(s) are missing from ",INST(INSTDA) S FAC=1
77 I $G(FAC) D
78 . W !,"= = = = ="
79 . W !!,"The above institution(s) will need to have their letter information edited",!,"before the letters for that facility can be printed",!
80 . K DIR S DIR(0)="EO" D ^DIR K DIR
81 . I X["^" S PSOSTOP=1
82 Q FAC
83 ;
84CHKINST(INSTDA) ; check institution in 52.92 for required edited fields
85 N XX,FAC,PAR S FAC=""
86 ; see if parent, parent checks OK
87 S PAR=$$GET1^DIQ(52.92,INSTDA,.02,"I") I PAR S XX=$$CHKINST(PAR) Q XX
88 F YY=.05,.07,.08,2.01 S XX=$$GET1^DIQ(52.92,INSTDA,YY) I $L(XX)=0 S FAC=FAC_YY_","
89 Q FAC
90PTCHK() ; Check file 52.91 for INST fields and 52.92 for INSTUTITONs present
91 N INST,CHK,INSTDA S INSTDA=0,CHK=0
92 F S INSTDA=$O(^PS(52.91,"AC",INSTDA)) Q:INSTDA'>0 D
93 . I $D(^PS(52.92,INSTDA)) Q
94 . S CHK=1
95 . W !!,$$GET1^DIQ(4,INSTDA,.01),!," is missing from the TRANSITIONAL RX INSTITUTION LETTERS file #52.92",!,"and is being added."
96 . S LOCDA=INSTDA N INST,FAC D LOCDA ; add INSTDA to # 52.92
97 I CHK D
98 . W !,"= = = = ="
99 . W !!,"The above institution(s) will need to have their letter information edited",!,"before the letters for that facility can be printed",!
100 . K DIR S DIR(0)="EO",DIR("A")="<cr> - Continue" D ^DIR K DIR
101 Q CHK
Note: See TracBrowser for help on using the repository browser.