source: FOIAVistA/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBIND.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 4.6 KB
Line 
1ALPBIND ;OIFO-DALLAS/SED/KC/MW BCMA-BCBU INPT TO HL7 INIT ;5/2/2002
2 ;;3.0;BAR CODE MED ADMIN;**8**;Mar 2004
3 ;
4 ; Reference/IA
5 ; DPT/10035
6 ; DIC(42/10039
7 ; DIC(42/2440
8 ; EN^PSJBCBU/3876
9 Q
10OPT ;Entry point for the option
11 ;Select Workstations assigned to Default.
12DFT K ALPHLL,DIR,ALPDIV,DTOUT,DUOUT,DIRUT,DIROUT
13 D GET^ALPBPARM(.ALPHLL,"")
14 I '$D(ALPHLL) W !,"No workstations defined for default " G EXIT
15 D ALLWKS
16 ;D:'$D(DIRUT) QUE
17 D QUE
18 G EXIT
19 ;
20ALLWKS ;If no then set allow the user to select the workstation
21 K DTOUT,DUOUT,DIRUT,DIROUT,DIR
22 S DIR(0)="Y",DIR("B")="YES"
23 S DIR("A")="Enter Yes or No"
24 S DIR("A",1)="Include all workstations"
25 D ^DIR
26 I $D(DIRUT) Q
27 S ALPWKS=+Y
28 I +ALPWKS>0 Q
29 ;
30WRKSTN ;Now select which workstations to be initialized
31 K ALPSCRN,ALPBANS
32 ;Set up screen
33 S ALP=0 F S ALP=$O(ALPHLL("LINKS",ALP)) Q:+ALP'>0 D
34 . S ALPSCRN($P(ALPHLL("LINKS",ALP),U,2),ALP)=ALPHLL("LINKS",ALP)
35 K ALPHLL
36 F D LP Q:$D(DIRUT)
37 ;I $D(DIRUT)&($D(ALPHLL)) W !!,"No Selected Workstations" G ALLWKS
38 I '$D(ALPBANS)!$D(ALPHLL) W !!,"No Selected Workstations" G ALLWKS
39 Q:'$D(ALPBANS)
40 S ALP="",ALPCNT=1
41 F S ALP=$O(ALPBANS(ALP)) Q:ALP="" D
42 . S ALPHLL("LINKS",ALPCNT)=ALPSCRN(ALP,$O(ALPSCRN(ALP,0)))
43 . S ALPCNT=ALPCNT+1
44 K ALPSCRN,ALPBANS
45 Q
46 ;
47LP ;Multiple entries
48 K DIR,DTOUT,DUOUT,DIRUT,DIROUT
49 S DIR(0)="PO^870:EMZ",DIR("A")="Select WorkStation Link "
50 S DIR("?")="Answer with WorkStation Link to update "
51 S DIR("S")="I $D(ALPSCRN($P(^HLCS(870,+Y,0),U,1)))"
52 D ^DIR
53 Q:$D(DIRUT)
54 S ALPBANS($P(Y,U,2),+Y)=""
55 W #,!!,"Selected Workstations",!!
56 S ALPB=""
57 F ALP=1:1 S ALPB=$O(ALPBANS(ALPB)) Q:ALPB="" D
58 .W ?$S(ALP#2:1,1:40),ALPB
59 .W:ALP#2'>0 !
60 Q
61 ;
62QUE ;Que the job
63 ;W !,"QUE"
64 S ZTRTN="EN^ALPBIND"
65 S ZTDESC="PSB - Initialize Default Contingency Workstation"
66 S ZTIO="",ZTSAVE("ALPWKS")=""
67 I $D(ALPHLL) S ZTSAVE("ALPHLL(")=""
68 D ^%ZTLOAD
69 W:$D(ZTSK) !,ZTSK
70 K ZTIO,ZTDESC,ZTRTN,ZTSK
71 Q
72EN ;Loop through the inpatient list.
73 Q:'$D(ALPHLL)
74 S ALPDTS=$$FMTE^XLFDT($$NOW^XLFDT)
75 K ALPSCR
76 S ALPSTOP=0,ALPOK=1
77 S ALPCN=""
78 F S ALPCN=$O(^DPT("CN",ALPCN)) Q:ALPCN=""!(ALPSTOP) D
79 . ;DIVISION SCREEN HERE
80 . S ALPCNI=$O(^DIC(42,"B",ALPCN,0))
81 . Q:+ALPCNI'>0 ;Quit if I can't decifer the Ward Location
82 . S ALPDIV=$P($G(^DIC(42,ALPCNI,0)),U,11)
83 . ;Check to see is the Division has Machines defined to it.
84 . ;if it does then it is not to go to default
85 . K ALPTEST
86 . D GET^ALPBPARM(.ALPTEST,ALPDIV,1)
87 . Q:$D(ALPTEST)
88 . S ALPSTOP=$$S^%ZTLOAD()
89 . S ALDFN=0
90 . F S ALDFN=$O(^DPT("CN",ALPCN,ALDFN)) Q:+ALDFN'>0!(ALPSTOP) D PAT
91 K XQA,XQAMSG
92 S ALPDTE=$$FMTE^XLFDT($$NOW^XLFDT)
93 S XQA(DUZ)=""
94 S XQAMSG="BCBU WORKSTATION INIT Started "_ALPDTS_" and finished "_ALPDTE_". "
95 ;_ALPBK_" entries sent."
96 D SETUP^XQALERT
97EXIT ;
98 K ALPDTS,ALPDTE,ALPCNT
99 K ALPB,ALPBI,ALPBJ,ALPCN,ALDFN,ALPMDT,ALPML,ALPORDR,MSCTR,MSH,ORC
100 K PID,PV1,ALPHLL,ALPALL,DIR,Y,DTOUT,DUOUT,DIRUT,DIROUT,ALPDIV
101 K ALPTST,ALPSTOP,ALPOK,ZTSAVE,ALPCNI,ALPCNT,ALP,ALPDVN,ALPSLT,ALPWKS
102 K PID,PV1,^TMP("PSJ",$J),^TMP("PSJBU",$J)
103 ;
104 Q
105MLOG ;Need to loop though the Med log file to get all med logs
106 ;associated with the order
107 Q:'$D(^PSB(53.79,"AORDX",ALDFN,ALPORDR))
108 S X=+$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP MEDLG",1,"Q")
109 S X=$S(X>0:"T-"_X,1:"T-30")
110 D ^%DT
111 Q:+Y'>0 ;Cannot get a valid date
112 S ALPMDT=Y
113 F S ALPMDT=$O(^PSB(53.79,"AORDX",ALDFN,ALPORDR,ALPMDT)) Q:+ALPMDT'>0 D
114 . S ALPML=0
115 . F S ALPML=$O(^PSB(53.79,"AORDX",ALDFN,ALPORDR,ALPMDT,ALPML)) Q:+ALPML'>0 D
116 . . Q:+$P($G(^PSB(53.79,ALPML,0)),U,1)'>0 ; Bad Med-log
117 . . ;W !,ALPML
118 . . S ALPRSLT=$$MEDL^ALPBINP(ALPML)
119 Q
120MESS ;BUILD AND SEND MESSAGE
121 K ALPB
122 D EN^PSJBCBU(ALDFN,ALPORDR,.ALPB)
123 S ALPBI=0
124 F S ALPBI=$O(ALPB(ALPBI)) Q:ALPBI'>0 D
125 . I $E(ALPB(ALPBI),1,3)="MSH" S MSH=ALPBI
126 . I $E(ALPB(ALPBI),1,3)="PID" S PID=ALPBI
127 . I $E(ALPB(ALPBI),1,3)="PV1" S PV1=ALPBI
128 . I $E(ALPB(ALPBI),1,3)="ORC" S ORC=ALPBI
129 I +MSH'>0 Q ;MISSING MSH SEGMENT BAD MESSAGE
130 S MSCTR=$E(ALPB(MSH),4,8),ALPORD=ALPORDR
131 S X=$$INI^ALPBINP()
132 Q
133SNDPT ;Send a Single Patient
134 K DIR,DTOUT,DUOUT,DIRUT,DIROUT
135 S DIR(0)="PO^2:EM",DIR("A")="Select Patient "
136 D ^DIR
137 Q:$D(DIRUT)
138 Q:+Y'>0
139 ;S ALDFN=10748
140 S ALDFN=+Y
141 W !!,"Please Hold On While I send the orders",!!
142 ;
143PAT ;
144 K ^TMP("PSJBU",$J)
145 S X=+$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP IPH",1,"Q")
146 S X=$S(X>0:"T-"_X,1:"T-15")
147 D ^%DT
148 Q:+Y'>0 ;Cannot get a valid date
149 D EN2^PSJBCBU(ALDFN,Y)
150 Q:'$D(^TMP("PSJBU",$J)) ; NO DATA
151 S ALPBJ=0
152 F S ALPBJ=$O(^TMP("PSJBU",$J,ALPBJ)) Q:+ALPBJ'>0 D
153 . Q:'$D(^TMP("PSJBU",$J,ALPBJ,0))
154 . S ALPORDR=$P(^TMP("PSJBU",$J,ALPBJ,0),U,3)
155 . Q:+ALPORDR'>0
156 . D MESS
157 . Q:ALPORDR["P" ;If not pending do Med-Log
158 . D MLOG
159 S ALPSTOP=$$S^%ZTLOAD()
160 Q
Note: See TracBrowser for help on using the repository browser.