Changeset 623 for WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- Location:
- WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED
- Files:
-
- 63 edited
-
XGKB.m (modified) (1 diff)
-
XPDDP.m (modified) (1 diff)
-
XPDIA3.m (modified) (1 diff)
-
XPDIST.m (modified) (1 diff)
-
XPDTA.m (modified) (1 diff)
-
XPDTA2.m (modified) (1 diff)
-
XQ3.m (modified) (1 diff)
-
XQ5.m (modified) (1 diff)
-
XQ55.m (modified) (1 diff)
-
XQ81.m (modified) (1 diff)
-
XQALDATA.m (modified) (1 diff)
-
XQALDEL.m (modified) (1 diff)
-
XQALERT1.m (modified) (1 diff)
-
XQALMAKE.m (modified) (1 diff)
-
XQALSET.m (modified) (1 diff)
-
XQALSET1.m (modified) (1 diff)
-
XQALSUR1.m (modified) (1 diff)
-
XQALSURO.m (modified) (1 diff)
-
XQARPRT2.m (modified) (1 diff)
-
XQCHK.m (modified) (1 diff)
-
XQCHK2.m (modified) (1 diff)
-
XQOR.m (modified) (1 diff)
-
XQOR4.m (modified) (1 diff)
-
XUP.m (modified) (1 diff)
-
XUPROD.m (modified) (1 diff)
-
XUS.m (modified) (1 diff)
-
XUS2.m (modified) (1 diff)
-
XUSCLEAN.m (modified) (1 diff)
-
XUSERBLK.m (modified) (1 diff)
-
XUSERNEW.m (modified) (1 diff)
-
XUSNPI.m (modified) (1 diff)
-
XUSNPIDA.m (modified) (1 diff)
-
XUSNPIE1.m (modified) (1 diff)
-
XUSNPIE2.m (modified) (1 diff)
-
XUSNPIED.m (modified) (1 diff)
-
XUSNPIX1.m (modified) (1 diff)
-
XUSNPIX2.m (modified) (1 diff)
-
XUSNPIX3.m (modified) (1 diff)
-
XUSNPIX4.m (modified) (1 diff)
-
XUSNPIX5.m (modified) (1 diff)
-
ZIS.m (modified) (1 diff)
-
ZIS1.m (modified) (1 diff)
-
ZIS2.m (modified) (1 diff)
-
ZIS3.m (modified) (1 diff)
-
ZIS4GTM.m (modified) (1 diff)
-
ZIS4ONT.m (modified) (1 diff)
-
ZIS6.m (modified) (1 diff)
-
ZISC.m (modified) (1 diff)
-
ZISEDIT.m (modified) (1 diff)
-
ZISHONT.m (modified) (1 diff)
-
ZISS1.m (modified) (1 diff)
-
ZOSFONT.m (modified) (1 diff)
-
ZOSVONT.m (modified) (1 diff)
-
ZTLOAD4.m (modified) (1 diff)
-
_ZIS.m (modified) (1 diff)
-
_ZIS1.m (modified) (1 diff)
-
_ZIS2.m (modified) (1 diff)
-
_ZIS3.m (modified) (1 diff)
-
_ZIS4.m (modified) (1 diff)
-
_ZIS6.m (modified) (1 diff)
-
_ZISC.m (modified) (1 diff)
-
_ZISS1.m (modified) (1 diff)
-
_ZTLOAD4.m (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XGKB.m
r613 r623 1 XGKB ;SFISC/VYD - Read with Escape Processing ;10/23/20062 ;;8.0;KERNEL;**34,244,365**;Jul 10, 1995;Build53 4 5 INIT(XGTRM) 6 7 8 9 10 I %OS["OpenM" U $I:(:"CT") D:'$D(^XUTL("XGKB")) DTM^XGKB1 S:$G(XGTRM)="*" XGTRM="" 11 12 13 14 15 16 17 18 EXIT 19 20 21 22 23 24 25 26 27 28 29 ACTION(XGKEY,XGACTION) 30 31 32 33 34 35 36 37 38 READ(XGCHARS,XGTO) 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 TEST 64 1 XGKB ;SFISC/VYD - Read with Escape Processing ;07/10/2002 10:58 2 ;;8.0;KERNEL;**34,244**;Jul 10, 1995 3 ;;Special thanks to MELDRUM.KEVIN@ISC-SLC.VA.GOV 4 ; 5 INIT(XGTRM) ;turn escape processing on and passed terminator string if any 6 N %,%OS S %OS=^%ZOSF("OS") 7 I %OS["VAX DSM" U $I:(NOLINE:ESCAPE) D:'$D(^XUTL("XGKB")) VAXDSM^XGKB1 8 I %OS["MSM" U $I:(0::::64) D:'$D(^XUTL("XGKB")) MSM^XGKB1 9 I %OS["DTM" U $I:(VT=1:ESCAPE=1) D:'$D(^XUTL("XGKB")) DTM^XGKB1 10 I %OS["OpenM" U $I:(:"CT") D:'$D(^XUTL("XGKB")) DTM^XGKB1 11 I %OS["GT.M" U $I:(ESCAPE) D:'$D(^XUTL("XGKB")) GTM^XGKB1 12 I $G(XGTRM)="*" X ^%ZOSF("TRMON") I 1 ;turn all on 13 E I $L($G(XGTRM)) S %=$$SETTRM^%ZOSV(XGTRM) ;turn on passed terminators 14 S XGRT="" 15 Q 16 ; 17 ; 18 EXIT ; Reset device (disable escape processing, turn terminators off) 19 N %OS S %OS=^%ZOSF("OS") 20 I %OS["VAX DSM" U $I:(LINE:NOESCAPE) 21 I %OS["MSM" U $I:(0:::::64) 22 I %OS["DTM" U $I:(ESCAPE=0) 23 I %OS["GT.M" U $I:(NOESCAPE) 24 X ^%ZOSF("TRMOFF") 25 K XGRT 26 Q 27 ; 28 ; 29 ACTION(XGKEY,XGACTION) ;add or remove key-action 30 ;XGKEY:key mnemonic ("F10","NEXT",etc.) 31 ;XGACTION:M executable string 32 ;if action is passed ADD mode is assumed otherwise REMOVE 33 I $D(XGACTION) S ^TMP("XGKEY",$J,XGKEY)=XGACTION 34 E K ^TMP("XGKEY",$J,XGKEY) 35 Q 36 ; 37 ; 38 READ(XGCHARS,XGTO) ; read XGCHARS using escape processing. XGTO timeout (optional). Result returned. 39 ; Char that terminated the read will be in XGRT 40 N S,XGW1,XGT1,XGSEQ ;string,window,timer,timer sequence 41 K DTOUT 42 S XGRT="" 43 D:$G(XGTO)="" ;set timeout value if one wasn't passed 44 . I $D(XGT) D Q ;if timers are defined 45 . . S XGTO=$O(XGT(0,"")) ;get shortest time left of all timers 46 . . S XGW1=$P(XGT(0,XGTO,$O(XGT(0,XGTO,"")),"ID"),U,1) ;get timer's window 47 . . S XGT1=$P(XGT(0,XGTO,$O(XGT(0,XGTO,"")),"ID"),U,3) ;get timer's name 48 . I $D(XGW) S XGTO=99999999 Q ;in emulation read forever 49 . S XGTO=$G(DTIME,600) 50 ; 51 I $G(XGCHARS)>0 R S#XGCHARS:XGTO S:'$T DTOUT=1 I 1 ;fixed length read 52 E R S:XGTO S:'$T DTOUT=1 I 1 ;read as many as possible 53 S:$G(DTOUT)&('$D(XGT1)) S=U ;stuff ^ 54 ; 55 S:$L($ZB) XGRT=$G(^XUTL("XGKB",$ZB)) ;get terminator if any 56 I $G(DTOUT),$D(XGT1),$D(^TMP("XGW",$J,XGW1,"T",XGT1,"EVENT","TIMER")) D I 1 ;if timed out 57 . D E^XGEVNT1(XGW1,"T",XGT1,"","TIMER") 58 E I $L(XGRT),$D(^TMP("XGKEY",$J,XGRT)) X ^(XGRT) ;do some action 59 ; this really should be handled by keyboard mapping -- later 60 Q S 61 ; 62 ; 63 TEST F S X=$$READ Q:X["^" W ?20,X,?40,XGRT,?60,$ZB,! 64 Q -
WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XPDDP.m
r613 r623 1 XPDDP ;SFISC/RSD - Display a package ;03/18/2008 2 ;;8.0;KERNEL;**21,28,44,68,100,108,229,304,346,463,488**;Jul 10, 1995;Build 6 3 ; Per VHA Directive 2004-038, this routine should not be modified. 4 ; Options: XPD PRINT BUILD calls EN1 5 ; XPD PRINT INSTALL calls EN2 6 EN1 ; Print from Build file 7 N DIC,D0,XPD,XPDT,XPDST,Y 8 S XPDST=$$LOOK^XPDB1 Q:XPDST<0 9 S XPD("XPDT(")="" 10 D EN^XUTMDEVQ("LST1^XPDDP","Build File Print",.XPD) 11 Q 12 EN2 ; Print from Distribution 13 N D0,DIC,POP,XPD,XPDA,XPDNM,XPDT,XPDST,Y,Z,%ZIS 14 S XPDST=$$LOOK^XPDI1("I $D(^XTMP(""XPDI"",Y))",1) 15 S D0=$O(^XTMP("XPDI",XPDST,"BLD",0)) Q:'D0 16 S XPD("XPDT(")="" 17 D EN^XUTMDEVQ("LST2^XPDDP","Transport Global Print",.XPD) 18 Q 19 LST1 ; Print from Build file 20 K DIRUT N XPDIT,XPDCNT S (XPDIT,XPDCNT)=0 21 F S XPDIT=$O(XPDT(XPDIT)) Q:$D(DIRUT)!(XPDIT'>0) D Q:$D(DIRUT) 22 . I XPDCNT Q:'$$CONT 23 . S XPDCNT=XPDCNT+1 24 . S D0=+XPDT(XPDIT) D PNT("XPD(9.6,D0)") 25 D WAIT 26 Q 27 LST2 ; Print from XPDT array 28 K DIRUT N XPDIT,XPDCNT S (XPDIT,XPDCNT)=0 29 F S XPDIT=$O(XPDT(XPDIT)) Q:$D(DIRUT)!(XPDIT'>0) D Q:$D(DIRUT) 30 . I XPDCNT Q:'$$CONT 31 . S XPDCNT=XPDCNT+1 32 . S XPDA=+XPDT(XPDIT),D0=$O(^XTMP("XPDI",XPDA,"BLD",0)) D PNT("XTMP(""XPDI"",XPDA,""BLD"",D0)") 33 D WAIT 34 Q 35 WAIT ; Pause on last page or not? It depends on whether there's enough room 36 ; left on the page to display the KIDS menu. 37 Q:$E($G(IOST),1,2)'="C-" 38 Q:$D(DIRUT) 39 ; DUZ("AUTO")=1 means show menu option choices 40 I IOSL-$Y<$S($G(DUZ("AUTO")):14,1:3) D WAIT^XMXUTIL 41 Q 42 PNT(XPDGR) ; Print a package, XPDGR=global root 43 ;XPDFL=0 - Build - ^XPD(9.7 global root 44 ; 1 - Install - ^XTMP global root 45 ; 2 - Packman - ^TMP($J, global root 46 N I,J,K,X,XPD,XPDDT,XPDI,XPD0,XPDFL,XPDPG,XPDUL,XPDTYPE,XPDTRACK,XPDTXT 47 Q:$G(XPDGR)="" S XPDGR="^"_XPDGR 48 Q:'$D(@XPDGR@(0)) 49 D ID ; Package Identification 50 D DESCR Q:$D(DIRUT) ; Description 51 I XPDTYPE=1 D MULT Q ; Multi-Package 52 D PREPOST Q:$D(DIRUT) ; Environment check & Pre/Post Routines 53 I XPDTYPE=2 D GLOBAL Q ; Global Package 54 D FILES Q:$D(DIRUT) ; Files/DDs 55 D COMP Q:$D(DIRUT) ; Build Components 56 Q:XPDFL=2 ; Packman message, called from XMP2 - Summarize 57 D QUESTS Q:$D(DIRUT) ; Install Questions 58 D ALFABETA Q:$D(DIRUT) ; Alpha/Beta Testing 59 D NAMESP Q:$D(DIRUT) ; Include/Exclude Namespaces 60 D REQDBLD Q:$D(DIRUT) ; Required Builds 61 Q 62 ID ; Identify the package 63 S XPD0=^(0),XPDPG=1,XPDFL=$S($E(XPDGR,1,5)="^TMP(":2,1:$E(XPDGR,1,5)="^XTMP"),$P(XPDUL,"-",IOM)="",XPDDT=$$HTE^XLFDT($H,"1PM"),XPDTYPE=+$P(XPD0,U,3),XPDTRACK=$P(XPD0,U,5) 64 W:$E(IOST,1,2)="C-" @IOF D HDR W !,XPDUL 65 W !,"TYPE: ",$$EXTERNAL^DILFD(9.6,2,"",XPDTYPE) 66 W ?51,"TRACK NATIONALLY: ",$$EXTERNAL^DILFD(9.6,5,"",XPDTRACK) 67 W !,"NATIONAL PACKAGE: ",$P($G(^DIC(9.4,+$P(XPD0,U,2),0),$P(XPD0,U,2)),U) 68 W ?49,"ALPHA/BETA TESTING: ",$S($P($G(@XPDGR@("ABPKG")),U)="y":"YES",1:"NO") 69 Q 70 DESCR ; Show patch description 71 W !!,"DESCRIPTION:" 72 S XPDI=0 73 F S XPDI=$O(@XPDGR@(1,XPDI)) Q:'XPDI S XPDTXT=$G(^(XPDI,0)) D Q:$D(DIRUT) 74 . I $L(XPDTXT)'<IOM,$E(XPDTXT,$L(XPDTXT))=" " F S XPDTXT=$E(XPDTXT,1,$L(XPDTXT)-1) Q:$E(XPDTXT,$L(XPDTXT))'=" " 75 . F D Q:$L(XPDTXT)<IOM!$D(DIRUT)!(IOM<2) S XPDTXT=$E(XPDTXT,IOM,999) 76 . . Q:$$CHK(2) 77 . . W !,$S(IOM>1:$E(XPDTXT,1,IOM-1),1:XPDTXT) 78 Q 79 PREPOST ; Environment check and pre/post routines 80 Q:$$CHK(3) 81 W !!,"ENVIRONMENT CHECK: ",$G(@XPDGR@("PRE")) 82 W ?49,"DELETE ENV ROUTINE: " I $G(@XPDGR@("PRE"))]"" W $S($P($G(@XPDGR@("INID")),U)="y":"Yes",1:"No") 83 I 'XPDTYPE D Q:$D(DIRUT) 84 . Q:$$CHK(2) 85 . W !," PRE-INIT ROUTINE: ",$G(@XPDGR@("INI")) 86 . W ?44,"DELETE PRE-INIT ROUTINE: " I $G(@XPDGR@("INI"))]"" W $S($P($G(@XPDGR@("INID")),U,3)="y":"Yes",1:"No") 87 Q:$$CHK(2) 88 W !,"POST-INIT ROUTINE: ",$G(@XPDGR@("INIT")) 89 W ?43,"DELETE POST-INIT ROUTINE: " I $G(@XPDGR@("INIT"))]"" W $S($P($G(@XPDGR@("INID")),U,2)="y":"Yes",1:"No") 90 I 'XPDTYPE Q:$$CHK(2) W !,"PRE-TRANSPORT RTN: ",$G(@XPDGR@("PRET")) 91 Q 92 FILES ; Show files/DDs 93 Q:'$O(@XPDGR@(4,0)) ; Quit if no files 94 S I=$$CHK(8,1) Q:I I '$P(I,"^",2) D HDR1 W !,XPDUL 95 S XPDI=0 96 F S XPDI=$O(@XPDGR@(4,XPDI)) Q:'XPDI S XPD=$G(^(XPDI,222)) Q:$$CHK(3,1) D 97 . ;file number, file name, partial DD 98 . W !!,XPDI,?12,$S('XPDFL:$P($G(^DIC(XPDI,0),"**unknown**"),U),1:$G(^XTMP("XPDI",XPDA,"FIA",XPDI))) 99 . ; update DD, send security code, data comes with file 100 . W ?43,$$EXTERNAL^DILFD(9.64,222.1,"",$P(XPD,U)),?49,$$EXTERNAL^DILFD(9.64,222.2,"",$P(XPD,U,2)),?55,$$EXTERNAL^DILFD(9.64,222.7,"",$P(XPD,U,7)) 101 . ; override site data, resolve pointers, user override 102 . W ?63,$E($$EXTERNAL^DILFD(9.64,222.8,"",$P(XPD,U,8)),1,4),?69,$$EXTERNAL^DILFD(9.64,222.5,"",$P(XPD,U,5)),?75,$$EXTERNAL^DILFD(9.64,222.9,"",$P(XPD,U,9)) 103 . I $P(XPD,U,3)="p" D Q:$D(DIRUT) 104 . . ; Print partial DD information 105 . . N XPDSUB,XPDFLD 106 . . Q:$$CHK(2,1) 107 . . W !,"Partial DD:" 108 . . S (J,XPDSUB)=0 109 . . F S J=$O(@XPDGR@(4,"APDD",XPDI,J)) Q:'J D Q:$D(DIRUT) 110 . . . I XPDSUB Q:$$CHK(2,1) W ! 111 . . . W ?12,"subDD: ",J 112 . . . S XPDSUB=1,(I,XPDFLD)=0 113 . . . F S I=$O(@XPDGR@(4,"APDD",XPDI,J,I)) Q:'I D Q:$D(DIRUT) 114 . . . . I XPDFLD Q:$$CHK(2,1) W ! 115 . . . . W ?30,"fld: ",I S XPDFLD=1 116 . I " "'[$G(@XPDGR@(4,XPDI,223)) Q:$$CHK(2,1) W !,?2,"DD SCREEN : ",^(223) 117 . I " "'[$G(@XPDGR@(4,XPDI,224)) Q:$$CHK(2,1) W !,?2,"DATA SCREEN: ",^(224) 118 Q 119 COMP ; Print Build components 120 S I=0,XPD=$P(^DD(9.68,.03,0),U,3) 121 F S I=$O(@XPDGR@("KRN",I)) Q:'I D Q:$D(DIRUT) 122 . Q:'$D(@XPDGR@("KRN",I,"NM","B")) 123 . Q:$$CHK(4) 124 . W !!,$S($D(^DIC(I,0)):$P(^(0),U),XPDFL:$G(^XTMP("XPDI",XPDA,"FIA",I),"UNKNOWN"),1:"UNKNOWN")_":",?47,"ACTION:" 125 . S J="" 126 . F S J=$O(@XPDGR@("KRN",I,"NM","B",J)) Q:J="" S X=$O(^(J,0)) D Q:$D(DIRUT) 127 . . Q:'X 128 . . S X=$G(@XPDGR@("KRN",I,"NM",X,0)) Q:X="" 129 . . Q:$$CHK(2) 130 . . ;write the entry name and write the action 131 . . W !,?3,$P(X,U),?50,$P($P(XPD,";",$P(X,U,3)+1),":",2) 132 Q 133 QUESTS ; Show Install Questions 134 I '$O(@XPDGR@("QUES",0)),'($D(@XPDGR@("QDEF"))#2) Q 135 Q:$$CHK(6) 136 W !!,"INSTALL QUESTIONS: " 137 S I=0 138 F S I=$O(@XPDGR@("QUES",I)) Q:'I S X=$P(^(I,0),U),J=$G(^(1)),K=$G(^("A")) D Q:$D(DIRUT) 139 . Q:$$CHK(4) 140 . W !!?5,"SUBSCRIPT: ",X 141 . W !,"DIR(0)=",J 142 . S J=0 143 . F S J=$O(@XPDGR@("QUES",I,"A1",J)) Q:'J Q:$$CHK(2) W !,"DIR(""A"",",J,")=",^(J,0) 144 . I K]"" Q:$$CHK(2) W !,"DIR(""A"")=",K 145 . I $G(@XPDGR@("QUES",I,"B"))]"" Q:$$CHK(2) W !,"DIR(""B"")=",^("B") 146 . S J=0 147 . F S J=$O(@XPDGR@("QUES",I,"Q1",J)) Q:'J Q:$$CHK(2) W !,"DIR(""?"",",J,")=",^(J,0) 148 . I $G(@XPDGR@("QUES",I,"Q"))]"" Q:$$CHK(2) W !,"DIR(""?"")=",^("Q") 149 . I $G(@XPDGR@("QUES",I,"QQ"))]"" Q:$$CHK(2) W !,"DIR(""??"")=",^("QQ") 150 . I $G(@XPDGR@("QUES",I,"M"))]"" Q:$$CHK(2) W !,"M CODE: ",^("M") 151 Q:$D(DIRUT) 152 ;Show new Defaults for KIDS questions. p463 153 S X=$G(@XPDGR@("QDEF")) Q:X="" 154 I '$L($P(X,U,9)),'$L($P(X,U,5)),'$L($P(X,U,11)) Q 155 Q:$$CHK(3) W ! 156 I $L($P(X,U,9)) Q:$$CHK(2) W !," Default Rebuild Menu Trees Upon Completion of Install: ",$P(X,U,9) 157 I $L($P(X,U,5)) Q:$$CHK(2) W !," Default INHIBIT LOGONs during the install: ",$P(X,U,5) 158 I $L($P(X,U,11)) Q:$$CHK(2) W !," Default DISABLE Scheduled Options, Menu Options, and Protocols: ",$P(X,U,11) 159 Q 160 ALFABETA ; Alpha/Beta Testing 161 S XPD=$G(@XPDGR@("ABPKG")) Q:XPD="" 162 Q:$P(XPD,U)'="y" 163 Q:$$CHK(4) 164 W !!,"ALPHA/BETA TESTING: ",$$EXTERNAL^DILFD(9.6,20,"",$P(XPD,U)),?47,"INSTALLATION MESSAGE: ",$$EXTERNAL^DILFD(9.6,21,"",$P(XPD,U,2)) 165 W !,"ADDRESS: ",$P(XPD,U,3) 166 Q 167 NAMESP ; Namespaces 168 Q:'$O(@XPDGR@("ABNS",0)) 169 Q:$$CHK(4) 170 W !!,"INCLUDE NAMESPACE:",?47,"EXCLUDE NAMESPACE:" 171 S I=0 172 F S I=$O(@XPDGR@("ABNS",I)) Q:'I Q:$$CHK(2) W !?3,^(I,0) D Q:$D(DIRUT) 173 . N XPDNMSP,XPDLF 174 . S (J,XPDLF)=0 175 . F S J=$O(@XPDGR@("ABNS",I,1,J)) Q:'J S XPDNMSP=^(J,0) D Q:$D(DIRUT) 176 . . I XPDLF Q:$$CHK(2) W ! 177 . . W ?50,XPDNMSP 178 . . S XPDLF=1 179 Q 180 REQDBLD ; Required Builds 181 Q:'$O(@XPDGR@("REQB",0)) 182 Q:$$CHK(4) 183 W !!,"REQUIRED BUILDS:",?47,"ACTION:" 184 S XPDI=0 185 F S XPDI=$O(@XPDGR@("REQB",XPDI)) Q:'XPDI S XPD=$G(^(XPDI,0)) Q:$$CHK(2) D 186 . W !?3,$P(XPD,U),?50,$$EXTERNAL^DILFD(9.611,1,"",$P(XPD,U,2)) 187 Q 188 GLOBAL ; Global Package 189 Q:$$CHK(4) 190 W !!,"GLOBAL:",?47,"KILL GLOBAL BEFORE INSTALL:" 191 S XPDI=0 192 F S XPDI=$O(@XPDGR@("GLO",XPDI)) Q:'XPDI S XPD=$G(^(XPDI,0)) Q:$$CHK(2) D 193 . W !?3,$P(XPD,U),?50,$$EXTERNAL^DILFD(9.65,1,"",$P(XPD,U,2)) 194 Q 195 MULT ; Multi-Package 196 Q:$$CHK(4) 197 W !!,"SEQUENCE OF BUILDS:" 198 S XPDI=0 199 F S XPDI=$O(@XPDGR@(10,XPDI)) Q:'XPDI S XPD=$G(^(XPDI,0)) Q:$$CHK(2) D 200 . W !?2,XPDI,?8,$E($P(XPD,U),1,44),?54,$S($P(XPD,U,2)=1:"",1:"Not ")_"Required to Continue" 201 Q 202 CHK(Y,XPD) ;Y=excess lines XPD=1 print file header, return 1 to exit 203 ;return 0 if header was not written, else "0^1" 204 Q:$Y<(IOSL-Y) 0 205 Q:'$$CONT 1 206 S XPD=$G(XPD),XPDPG=XPDPG+1 207 W @IOF D HDR,HDR1:XPD 208 W !,XPDUL 209 Q "0^1" 210 CONT() ; Press Return to continue; ^ to exit. 211 Q:$D(DIRUT) 0 212 Q:$E(IOST,1,2)'="C-" 1 213 N DIR,I,J,K,X,Y 214 S DIR(0)="E" D ^DIR 215 Q Y 216 XMP2(X,D0) ;called from ^XMP2 217 N XPDA S XPDA=-1 218 D PNT(X) 219 Q 220 HDR ; 221 W "PACKAGE: ",$P(XPD0,U)," ",XPDDT,?70,$$RJ^XLFSTR("PAGE "_XPDPG,9) 222 Q 223 HDR1 ; 224 W !!,?43,"UP SEND DATA USER" 225 W !,?43,"DATE SEC. COMES SITE RSLV OVER" 226 W !,"FILE #",?12,"FILE NAME",?43,"DD CODE W/FILE DATA PTRS RIDE" 227 Q 1 XPDDP ;SFISC/RSD - Display a package ;6/21/07 09:44 2 ;;8.0;KERNEL;**21,28,44,68,100,108,229,304,346,463**;Jul 10, 1995;Build 4 3 EN1 ;print from Build file 4 N DIC,D0,XPD,XPDT,XPDST,Y,Z 5 S XPDST=$$LOOK^XPDB1 Q:XPDST<0 6 S XPD("XPDT(")="",Y="LST1^XPDDP",Z="Build File Print" 7 D EN^XUTMDEVQ(Y,Z,.XPD) 8 Q 9 EN2 ;print from Distribution 10 N D0,DIC,POP,XPD,XPDA,XPDNM,XPDT,XPDST,Y,Z,%ZIS 11 S XPDST=$$LOOK^XPDI1("I $D(^XTMP(""XPDI"",Y))",1) 12 S XPD("XPDT(")="",Y="LST2^XPDDP",Z="Transport Global Print",D0=$O(^XTMP("XPDI",XPDST,"BLD",0)) 13 Q:'D0 14 D EN^XUTMDEVQ(Y,Z,.XPD) 15 Q 16 ; 17 LST1 ; 18 K DIRUT N XPDIT S XPDIT=0 19 F S XPDIT=$O(XPDT(XPDIT)) Q:$D(DIRUT)!(XPDIT'>0) D 20 . S D0=+XPDT(XPDIT) D PNT("XPD(9.6,D0)") 21 Q 22 ; 23 LST2 ;Print from XPDT array 24 K DIRUT N XPDIT S XPDIT=0 25 F S XPDIT=$O(XPDT(XPDIT)) Q:$D(DIRUT)!(XPDIT'>0) D 26 . S XPDA=+XPDT(XPDIT),D0=$O(^XTMP("XPDI",XPDA,"BLD",0)) D PNT("XTMP(""XPDI"",XPDA,""BLD"",D0)") 27 Q 28 ; 29 PNT(XPDGR) ;print a package, XPDGR=global root 30 ;XPDFL=0 - Build - ^XPD(9.7 global root, 1 - Install - ^XTMP global root 31 ;2 - Packman ^TMP($J, global root 32 N I,J,K,X,XPD,XPDDT,XPDI,XPD0,XPDFL,XPDPG,XPDUL,XPDTYPE,XPDTRACK,XPDTXT,XPDOUT 33 Q:$G(XPDGR)="" S XPDGR="^"_XPDGR 34 Q:'$D(@XPDGR@(0)) 35 S XPD0=^(0),XPDPG=1,XPDFL=$S($E(XPDGR,1,5)="^TMP(":2,1:$E(XPDGR,1,5)="^XTMP"),$P(XPDUL,"-",IOM)="",XPDDT=$$HTE^XLFDT($H,"1PM"),XPDTYPE=+$P(XPD0,U,3),XPDTRACK=$P(XPD0,U,5) 36 W:$E(IOST,1,2)="C-" @IOF D HDR W XPDUL,! 37 W "TYPE: ",$$EXTERNAL^DILFD(9.6,2,"",XPDTYPE) 38 W !,"TRACK NATIONALLY: ",$$EXTERNAL^DILFD(9.6,5,"",XPDTRACK) 39 W !,"NATIONAL PACKAGE: ",$P($G(^DIC(9.4,+$P(XPD0,U,2),0),$P(XPD0,U,2)),U) 40 W !,"ALPHA/BETA TESTING: ",$S($P($G(@XPDGR@("ABPKG")),U)="y":"YES",1:"NO") ; new line added. 41 W !,"DESCRIPTION:" 42 S (XPDI,XPDOUT)=0 43 F S XPDI=$O(@XPDGR@(1,XPDI)) Q:'XPDI S XPDTXT=$G(^(XPDI,0)) D Q:XPDOUT 44 . I $L(XPDTXT)'<IOM,$E(XPDTXT,$L(XPDTXT))=" " F S XPDTXT=$E(XPDTXT,1,$L(XPDTXT)-1) Q:$E(XPDTXT,$L(XPDTXT))'=" " 45 . F D Q:$L(XPDTXT)<IOM!XPDOUT!(IOM<2) S XPDTXT=$E(XPDTXT,IOM,999) 46 . . W $S(IOM>1:$E(XPDTXT,1,IOM-1),1:XPDTXT),! 47 . . S XPDOUT=$$CHK(2) 48 Q:$D(DIRUT) G:XPDTYPE=1 MULT 49 W !,"ENVIRONMENT CHECK : ",$G(@XPDGR@("PRE")) 50 W ?47,"DELETE ENV ROUTINE: ",$S($P($G(@XPDGR@("INID")),U)="y":"Yes",1:"No") 51 W ! 52 I 'XPDTYPE D 53 . W " PRE-INIT ROUTINE : ",$G(@XPDGR@("INI")) 54 . W ?42,"DELETE PRE-INIT ROUTINE: ",$S($P($G(@XPDGR@("INID")),U,3)="y":"Yes",1:"No") 55 . W ! 56 Q:$$CHK(4) W "POST-INIT ROUTINE : ",$G(@XPDGR@("INIT")) 57 W ?41,"DELETE POST-INIT ROUTINE: ",$S($P($G(@XPDGR@("INID")),U,2)="y":"Yes",1:"No") 58 W ! 59 W:'XPDTYPE "PRE-TRANSPORT RTN : ",$G(@XPDGR@("PRET")),! 60 G:XPDTYPE=2 GLOBAL 61 I '$O(@XPDGR@(4,0)) Q:$$CHK(4) G COMP 62 S I=$$CHK(10,1) Q:I I '$P(I,"^",2) W !! D HDR1 W XPDUL,! 63 PNT2 S XPDI=0 F S XPDI=$O(@XPDGR@(4,XPDI)) Q:'XPDI S XPD=$G(^(XPDI,222)) Q:$$CHK(4,1) D 64 .;file number, file name, partial DD 65 .W !,XPDI,?12,$S('XPDFL:$P($G(^DIC(XPDI,0),"**unknown**"),U),1:$G(^XTMP("XPDI",XPDA,"FIA",XPDI))) 66 .W ?41,$$EXTERNAL^DILFD(9.64,222.1,"",$P(XPD,U)),?47,$$EXTERNAL^DILFD(9.64,222.2,"",$P(XPD,U,2)),?53,$$EXTERNAL^DILFD(9.64,222.7,"",$P(XPD,U,7)) 67 .W ?60,$E($$EXTERNAL^DILFD(9.64,222.8,"",$P(XPD,U,8)),1,4),?67,$$EXTERNAL^DILFD(9.64,222.5,"",$P(XPD,U,5)),?73,$$EXTERNAL^DILFD(9.64,222.9,"",$P(XPD,U,9)),! 68 .;print partial DD information 69 .I $P(XPD,U,3)="p" S J=0 D 70 ..W "Partial DD:" 71 ..F S J=$O(@XPDGR@(4,"APDD",XPDI,J)) Q:'J W ?12,"subDD: ",J D Q:$$CHK(4,1) 72 ...I '$O(@XPDGR@(4,"APDD",XPDI,J,0)) W ! Q 73 ...S I=0 F S I=$O(@XPDGR@(4,"APDD",XPDI,J,I)) Q:'I W ?30,"fld: ",I,! 74 .I $D(@XPDGR@(4,XPDI,223)) W ?2,"DD SCREEN : ",^(223),! 75 .I $D(@XPDGR@(4,XPDI,224)) W ?2,"DATA SCREEN: ",^(224),! 76 COMP Q:$D(DIRUT) W ! Q:$$CHK(3) S I=0,XPD=$P(^DD(9.68,.03,0),U,3) 77 ;print build components 78 F S I=$O(@XPDGR@("KRN",I)),K=0,J="" Q:$D(DIRUT)!'I F S J=$O(@XPDGR@("KRN",I,"NM","B",J)) Q:J="" S X=$O(^(J,0)) Q:$$CHK(4) D:X 79 .S X=$G(@XPDGR@("KRN",I,"NM",X,0)) Q:X="" 80 .;K is flag to write type of component 81 .I 'K W !,$S($D(^DIC(I,0)):$P(^(0),U),XPDFL:$G(^XTMP("XPDI",XPDA,"FIA",I),"UNKNOWN"),1:"UNKNOWN")_":",! S K=1 82 .;write the entry name and write the action 83 .W ?3,$P(X,U),?50,$P($P(XPD,";",$P(X,U,3)+1),":",2),! 84 Q:XPDFL=2 85 ;XPDFL=2 this is a Packman message, called from XMP2 - Summarize 86 ;XPDFL=1 this is a Install, the call backs are already Build Components 87 Q:$D(DIRUT) Q:$$CHK(3) 88 I $O(@XPDGR@("QUES",0))!($D(@XPDGR@("QDEF"))#2) W !,"INSTALL QUESTIONS: " S I=0 D 89 .F S I=$O(@XPDGR@("QUES",I)) Q:'I S X=$P(^(I,0),U),J=$G(^(1)),K=$G(^("A")) Q:$$CHK(5) D 90 ..W !?5,"SUBSCRIPT: ",X,!,"DIR(0)=",J W:K]"" !,"DIR(""A"")=",K,! 91 ..F J=1:1 Q:'$D(@XPDGR@("QUES",I,"A1",J,0)) W "DIR(""A"",",J,")=",^(0),! 92 ..I $G(@XPDGR@("QUES",I,"B"))]"" W "DIR(""B"")=",^("B"),! 93 ..I $G(@XPDGR@("QUES",I,"Q"))]"" W "DIR(""?"")=",^("Q"),! 94 ..F J=1:1 Q:'$D(@XPDGR@("QUES",I,"Q1",J,0)) W "DIR(""?"",",J,")=",^(0),! 95 ..I $G(@XPDGR@("QUES",I,"QQ"))]"" W "DIR(""??"")=",^("QQ"),! 96 ..I $G(@XPDGR@("QUES",I,"M"))]"" W "M CODE: ",^("M"),! 97 . Q:$D(DIRUT) Q:$$CHK(3) 98 . ;Show new Defaults for KIDS questions. p463 99 . I $D(@XPDGR@("QDEF"))#2 S X=$G(@XPDGR@("QDEF")) D 100 . . W:$X>1 ! 101 . . I $L($P(X,U,9)) W " Default Rebuild Menu Trees Upon Completion of Install: ",$P(X,U,9),! 102 . . I $L($P(X,U,5)) W " Default INHIBIT LOGONs during the install: ",$P(X,U,5),! 103 . . I $L($P(X,U,11)) W " Default DISABLE Scheduled Options, Menu Options, and Protocols: ",$P(X,U,11) 104 . . Q 105 . Q 106 Q:$D(DIRUT) Q:$$CHK(3) 107 I $L($G(@XPDGR@("ABPKG"))) S XPD=^("ABPKG") D:$P(XPD,U)="y" 108 .W !,"ALPHA/BETA TESTING:",$$EXTERNAL^DILFD(9.6,20,"",$P(XPD,U)),?40,"INSTALLATION MESSAGE: ",$$EXTERNAL^DILFD(9.6,21,"",$P(XPD,U,2)) 109 .W !,"ADDRESS: ",$P(XPD,U,3),!!,"INCLUDE NAMESPACE",?30,"EXCLUDE NAMESPACE" S I=0 110 .F S I=$O(@XPDGR@("ABNS",I)),J=0 Q:'I W !?5,^(I,0) F S J=$O(@XPDGR@("ABNS",I,1,J)) Q:'J W ?35,^(J,0),! Q:$$CHK(3) 111 REQB Q:$D(DIRUT) Q:$$CHK(4) 112 I $O(@XPDGR@("REQB",0)) W !,"REQUIRED BUILDS:",?50,"ACTION:" D 113 .S XPDI=0 F S XPDI=$O(@XPDGR@("REQB",XPDI)) Q:'XPDI S XPD=$G(^(XPDI,0)) Q:$$CHK(4,1) D 114 ..W !?3,$P(XPD,U),?50,$$EXTERNAL^DILFD(9.611,1,"",$P(XPD,U,2)) 115 Q 116 GLOBAL ;globals listing 117 S I=$$CHK(8,1) Q:I I '$P(I,"^",2) W !!,"GLOBAL:",?20,"KILL GLOBAL BEFORE INSTALL:" 118 S XPDI=0 F S XPDI=$O(@XPDGR@("GLO",XPDI)) Q:'XPDI S XPD=$G(^(XPDI,0)) Q:$$CHK(4,1) D 119 .W !?3,$P(XPD,U),?33,$$EXTERNAL^DILFD(9.65,1,"",$P(XPD,U,2)) 120 W ! Q 121 ; 122 MULT ;multiple-package 123 S I=$$CHK(10,1) Q:I I '$P(I,"^",2) W !,"SEQUENCE OF BUILDS:" 124 S XPDI=0 F S XPDI=$O(@XPDGR@(10,XPDI)) Q:'XPDI S XPD=$G(^(XPDI,0)) Q:$$CHK(4,1) D 125 .W !?2,XPDI,?8,$E($P(XPD,U),1,44),?54,$S($P(XPD,U,2)=1:"",1:"Not ")_"Required to Continue" 126 W ! Q 127 ; 128 ;return 0 if header was not written, else "0^1" 129 CHK(Y,XPD) ;Y=excess lines XPD=1 print file header, return 1 to exit 130 Q:$Y<(IOSL-Y) 0 131 I $E(IOST,1,2)="C-" D Q:'Y 1 132 .N DIR,I,J,K,X 133 .S DIR(0)="E" D ^DIR 134 S XPD=$G(XPD),XPDPG=XPDPG+1 135 W @IOF D HDR,HDR1:XPD 136 W XPDUL,! 137 Q "0^1" 138 ; 139 XMP2(X,D0) ;called from ^XMP2 140 N XPDA S XPDA=-1 141 D PNT(X) Q 142 ; 143 HDR W !,"PACKAGE: ",$P(XPD0,U)," ",XPDDT,?70,"PAGE ",XPDPG,! 144 Q 145 HDR1 W ?41,"UP",?47,"SEND",?53,"DATA",?73,"USER",!,?41,"DATE",?47,"SEC.",?53,"COMES",?60,"SITE",?67,"RSLV",?73,"OVER" 146 W !,"FILE #",?12,"NAME",?41,"DD",?47,"CODE",?53,"W/FILE",?60,"DATA",?67,"PTS",?73,"RIDE",! 147 Q -
WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XPDIA3.m
r613 r623 1 XPDIA3 ;SFISC/RWF - Install Pre/Post Actions for Kernel files cont. ;6/22/06 09:13 2 ;;8.0;KERNEL;**201,302,393,498**;Jul 10, 1995;Build 13 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 Q 5 ;^XTMP("XPDI",,XPDA,"KRN",XPDFILE,OLDA) is the global root 6 ;XPDNM=package name, XPDA=ien in ^XPD(9.6, 7 ;DA=ien in file, OLDA= ien in ^XTMP 8 ; 9 PAR0F2 ;PARAMETER file 8989.5: post. This is a fake entry called from the post of file 8989.51 10 ;Now load any entries from 8989.5 11 N XP1,XP2,XP3,DIK,OLDA,DA,ERR,PN,PE,PT,ROOT 12 S XP1=$O(^XTMP("XPDI",XPDA,"PKG",0)) ;Get the package 13 Q:'XP1 S PN=$G(^XTMP("XPDI",XPDA,"PKG",XP1,0)) 14 S PE=$$FIND1^DIC(9.4,,"MX",$P(PN,U,2)) ;Get the IEN of the package 15 S OLDA=0,ROOT=$NA(^XTMP("XPDI",XPDA,"KRN",8989.5)) 16 F S OLDA=$O(@ROOT@(OLDA)) Q:'OLDA D 17 . S XP1=@ROOT@(OLDA,0) 18 . S $P(XP1,U,1)=PE_";DIC(9.4," ;entity 19 . S $P(XP1,U,2)=$$LK^XPDIA($NA(^XTV(8989.51)),$P(XP1,U,2)) 20 . S DA=$$LKPAR($P(XP1,U),$P(XP1,U,2),$P(XP1,U,3)) 21 . ;Remove the current entry if we have one 22 . I DA>0 S DIK="^XTV(8989.5," D ^DIK 23 . ;Otherwise Add the zero node, See that we have a IEN 24 . I DA'>0 D ADDPAR($P(XP1,U),$P(XP1,U,2),$P(XP1,U,3)) S DA=$$LKPAR($P(XP1,U),$P(XP1,U,2),$P(XP1,U,3)) 25 . Q:'DA ;don't have a entry 26 . ;Merge the date ;with IHS fix 27 . M ^XTV(8989.5,DA)=^XTMP("XPDI",XPDA,"KRN",8989.5,OLDA) 28 . S ^XTV(8989.5,DA,0)=XP1 ;zero node with new pointers 29 . ;Get Definition and check if Data Type is pointer, then get pointed to global ref. 30 . S PT=$G(^XTV(8989.51,+$P(XP1,U,2),1)) D:$P(PT,U)="P" 31 . . S XP3=$G(^XTV(8989.5,DA,1)),PT=$P(PT,U,2) 32 . . S:PT $P(XP3,U)=$$FIND1^DIC(PT,"","X",$P(XP3,U)) ;resolve pointer value 33 . . S:$P(XP3,U) ^XTV(8989.5,DA,1)=XP3 34 . ;X-ref it 35 . S DIK="^XTV(8989.5," D IX1^DIK 36 Q 37 ; 38 LKPAR(ENT,PAR,INST) ;Lookup an entry 39 Q $O(^XTV(8989.5,"AC",PAR,ENT,INST,0)) 40 ; 41 ADDPAR(ENT,PAR,INST) ;Add a parameter instance 42 N FDA,FDAIEN,DIERR 43 S FDA(8989.5,"+1,",.01)=ENT 44 S FDA(8989.5,"+1,",.02)=PAR 45 S FDA(8989.5,"+1,",.03)=INST 46 D UPDATE^DIE("","FDA","FDAIEN","DIERR") 47 Q 48 ; 49 PAR1F1 ;PARAMETER File 8989.51: file Pre 50 Q 51 PAR1E1 ;PARAMETER file 8989.51: entry pre 52 N XP1,XP2,XP3 53 S ^TMP($J,"XPD",DA)="" 54 ;if there is a new Description, kill the old Description 55 K:$O(^XTMP("XPDI",XPDA,"KRN",8989.51,OLDA,20,0)) ^XTV(8989.51,DA,20) 56 ;Kill any old Allowable entries 57 K:$O(^XTMP("XPDI",XPDA,"KRN",8989.51,OLDA,30,0)) ^XTV(8989.51,DA,30) 58 Q 59 PAR1F2 ;PARAMETER file 8989.51: file post 60 N XPD,DIK,DA 61 S DA=0 62 F S DA=$O(^TMP($J,"XPD",DA)) Q:'DA D 63 . S DIK="^XTV(8989.51," D IX1^DIK 64 D PAR0F2 ;Go load the entries from 8989.5 65 Q 66 PAR1DEL(RT) ;Delete Parameter Def entries 67 D DELPTR^XPDUTL1(8989.51,RT) ;Cleanup pointers 68 D DELIEN^XPDUTL1(8989.51,RT) ;Cleanup entries 69 Q 70 ; 71 PAR2F1 ;PARAMETER File 8989.52: file Pre 72 K ^TMP($J,"XPD") 73 Q 74 PAR2E1 ;PARAMETER file 8989.52: entry Pre 75 N XP1,XP2,ROOT 76 S ROOT=$NA(^XTMP("XPDI",XPDA,"KRN",8989.52)) 77 S XP2=$P(@ROOT@(OLDA,0),U,4) ;Use instance of 78 ;Because we change the transport global see that a restart will work 79 I $L(XP2),XP2?1A.E S $P(@ROOT@(OLDA,0),U,4)=$$LK^XPDIA($NA(^XTV(8989.51)),XP2) 80 S XP1=0 81 F S XP1=$O(@ROOT@(OLDA,10,XP1)),XP2="" Q:'XP1 D 82 . S XP2=$P(@ROOT@(OLDA,10,XP1,0),U,2) ;Parameter 83 . I $L(XP2),XP2?1A.E S $P(@ROOT@(OLDA,10,XP1,0),U,2)=$$LK^XPDIA($NA(^XTV(8989.51)),XP2) 84 . Q 85 Q 86 PAR2F2 ;PARAMETER file 8989.52: file Post 87 Q 88 PAR2DEL(RT) ;Delete Parameter Templates 89 D DELIEN^XPDUTL1(8989.52,RT) 90 Q 1 XPDIA3 ;SFISC/RWF - Install Pre/Post Actions for Kernel files cont. ;6/22/06 09:13 2 ;;8.0;KERNEL;**201,302,393**;Jul 10, 1995;Build 12 3 Q 4 ;^XTMP("XPDI",,XPDA,"KRN",XPDFILE,OLDA) is the global root 5 ;XPDNM=package name, XPDA=ien in ^XPD(9.6, 6 ;DA=ien in file, OLDA= ien in ^XTMP 7 ; 8 PAR0F2 ;PARAMETER file 8989.5: post. This is a fake entry called from the post of file 8989.51 9 ;Now load any entries from 8989.5 10 N XP1,XP2,DIK,OLDA,DA,ERR,PN,PE,ROOT 11 S XP1=$O(^XTMP("XPDI",XPDA,"PKG",0)) ;Get the package 12 Q:'XP1 S PN=$G(^XTMP("XPDI",XPDA,"PKG",XP1,0)) 13 S PE=$$FIND1^DIC(9.4,,"MX",$P(PN,U,2)) ;Get the IEN of the package 14 S OLDA=0,ROOT=$NA(^XTMP("XPDI",XPDA,"KRN",8989.5)) 15 F S OLDA=$O(@ROOT@(OLDA)) Q:'OLDA D 16 . S XP1=@ROOT@(OLDA,0) 17 . S $P(XP1,U,1)=PE_";DIC(9.4," ;entity 18 . S $P(XP1,U,2)=$$LK^XPDIA($NA(^XTV(8989.51)),$P(XP1,U,2)) 19 . S DA=$$LKPAR($P(XP1,U),$P(XP1,U,2),$P(XP1,U,3)) 20 . ;Remove the current entry if we have one 21 . I DA>0 S DIK="^XTV(8989.5," D ^DIK 22 . ;Otherwise Add the zero node, See that we have a IEN 23 . I DA'>0 D ADDPAR($P(XP1,U),$P(XP1,U,2),$P(XP1,U,3)) S DA=$$LKPAR($P(XP1,U),$P(XP1,U,2),$P(XP1,U,3)) 24 . Q:'DA ;don't have a entry 25 . ;Merge the date ;with IHS fix 26 . M ^XTV(8989.5,DA)=^XTMP("XPDI",XPDA,"KRN",8989.5,OLDA) 27 . S ^XTV(8989.5,DA,0)=XP1 ;zero node with new pointers 28 . ;X-ref it 29 . S DIK="^XTV(8989.5," D IX1^DIK 30 Q 31 ; 32 LKPAR(ENT,PAR,INST) ;Lookup an entry 33 Q $O(^XTV(8989.5,"AC",PAR,ENT,INST,0)) 34 ; 35 ADDPAR(ENT,PAR,INST) ;Add a parameter instance 36 N FDA,FDAIEN,DIERR 37 S FDA(8989.5,"+1,",.01)=ENT 38 S FDA(8989.5,"+1,",.02)=PAR 39 S FDA(8989.5,"+1,",.03)=INST 40 D UPDATE^DIE("","FDA","FDAIEN","DIERR") 41 Q 42 ; 43 PAR1F1 ;PARAMETER File 8989.51: file Pre 44 Q 45 PAR1E1 ;PARAMETER file 8989.51: entry pre 46 N XP1,XP2,XP3 47 S ^TMP($J,"XPD",DA)="" 48 ;if there is a new Description, kill the old Description 49 K:$O(^XTMP("XPDI",XPDA,"KRN",8989.51,OLDA,20,0)) ^XTV(8989.51,DA,20) 50 ;Kill any old Allowable entries 51 K:$O(^XTMP("XPDI",XPDA,"KRN",8989.51,OLDA,30,0)) ^XTV(8989.51,DA,30) 52 Q 53 PAR1F2 ;PARAMETER file 8989.51: file post 54 N XPD,DIK,DA 55 S DA=0 56 F S DA=$O(^TMP($J,"XPD",DA)) Q:'DA D 57 . S DIK="^XTV(8989.51," D IX1^DIK 58 D PAR0F2 ;Go load the entries from 8989.5 59 Q 60 PAR1DEL(RT) ;Delete Parameter Def entries 61 D DELPTR^XPDUTL1(8989.51,RT) ;Cleanup pointers 62 D DELIEN^XPDUTL1(8989.51,RT) ;Cleanup entries 63 Q 64 ; 65 PAR2F1 ;PARAMETER File 8989.52: file Pre 66 K ^TMP($J,"XPD") 67 Q 68 PAR2E1 ;PARAMETER file 8989.52: entry Pre 69 N XP1,XP2,ROOT 70 S ROOT=$NA(^XTMP("XPDI",XPDA,"KRN",8989.52)) 71 S XP2=$P(@ROOT@(OLDA,0),U,4) ;Use instance of 72 ;Because we change the transport global see that a restart will work 73 I $L(XP2),XP2?1A.E S $P(@ROOT@(OLDA,0),U,4)=$$LK^XPDIA($NA(^XTV(8989.51)),XP2) 74 S XP1=0 75 F S XP1=$O(@ROOT@(OLDA,10,XP1)),XP2="" Q:'XP1 D 76 . S XP2=$P(@ROOT@(OLDA,10,XP1,0),U,2) ;Parameter 77 . I $L(XP2),XP2?1A.E S $P(@ROOT@(OLDA,10,XP1,0),U,2)=$$LK^XPDIA($NA(^XTV(8989.51)),XP2) 78 . Q 79 Q 80 PAR2F2 ;PARAMETER file 8989.52: file Post 81 Q 82 PAR2DEL(RT) ;Delete Parameter Templates 83 D DELIEN^XPDUTL1(8989.52,RT) 84 Q -
WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XPDIST.m
r613 r623 1 XPDIST ;SFISC/RSD - site tracking; 06/01/2006 ;03/05/20082 ;;8.0;KERNEL;**66,108,185,233,350,393,486**;Jul 10, 1995;Build 5 3 ; Per VHA Directive 2004-038, this routine should not be modified. 4 ;Returns ""=failed, XMZ=sent 5 ;D0=ien in file 9.7, XPY=national site tracking^address(optional) 6 EN(D0,XPY) ;send message 7 N %,DIFROM,XPD,XPD0,XPD1,XPD2,XPDV,XPZ,X,X1,Z,Y,XPD6,XPDTRACK 8 ;Get data needed 9 I '$D(^XPD(9.7,$G(D0),0)) D BMES^XPDUTL(" INSTALL file entry missing") Q "" 10 ;p350 -add node 6 for the Test# and Seq#. -REM 11 S XPD0=^XPD(9.7,D0,0),XPD1=$G(^(1)),XPD2=$G(^(2)),XPD6=$G(^(6)) 12 I '$P(XPD0,U,2) D BMES^XPDUTL(" No link to PACKAGE file") Q "" 13 S XPD=$P($G(^DIC(9.4,+$P(XPD0,U,2),0)),U),XPDV=$$VER^XPDUTL($P(XPD0,U)) 14 I XPD="" D BMES^XPDUTL(" PACKAGE file entry missing") Q "" 15 ;XPZ(1)=start, XPZ(2)=completion date/time, XPZ(3)=run time 16 S XPZ(1)=$P(XPD1,U),XPZ(2)=$P(XPD1,U,3),XPZ(3)=$$FMDIFF^XLFDT(XPZ(2),XPZ(1),3),XPZ(1)=$$FMTE^XLFDT(XPZ(1)),XPZ(2)=$$FMTE^XLFDT(XPZ(2)) 17 D LOCAL 18 S XPDTRACK=$$TRACK 19 D REMEDY ;p350 -REM 20 Q $$FORUM() 21 LOCAL ;Send a message to local mail group 22 N XMY,XPDTEXT,XMTEXT,XMDUZ,XMSUB,XMZ 23 K ^TMP($J) 24 S X=$$MAILGRP^XPDUTL(XPD) Q:X=""25 S XMY(X)="" D GETENV^%ZOSV 26 ;Message for users 27 S XPDTEXT(1,0)="PACKAGE INSTALL" 28 S XPDTEXT(2,0)="SITE: "_$G(^XMB("NETNAME")) 29 S XPDTEXT(3,0)="PACKAGE: "_XPD 30 S XPDTEXT(4,0)="VERSION: "_XPDV 31 S XPDTEXT(5,0)="Start time: "_XPZ(1) 32 S XPDTEXT(6,0)="Completion time: "_XPZ(2) 33 S XPDTEXT(7,0)="Environment: "_Y 34 S XPDTEXT(8,0)="Installed by: "_$P($G(^VA(200,+$P(XPD0,U,11),0)),U)35 S XPDTEXT(9,0)="Install Name: "_$P(XPD0,U) 36 S XPDTEXT(10,0)="Distribution Date: "_$$FMTE^XLFDT($P(XPD1,U,4)) 37 S XMDUZ=$S($P(XPD0,U,11):+$P(XPD0,U,11),1:.5),XMTEXT="XPDTEXT(",XMSUB=$P(XPD0,U)_" INSTALLATION" 38 D ^XMD 39 Q 40 TRACK() ; Should VA track the installation of this patch at a national level? 41 Q:$G(XPY)="" 0 ; No - National site tracking was not requested 42 ;Quit if not VA production primary domain 43 I $G(^XMB("NETNAME"))'[".VA.GOV" D BMES^XPDUTL(" Not a VA primary domain") Q 0 44 ;X ^%ZOSF("UCI") S %=^%ZOSF("PROD") 45 ;S:%'["," Y=$P(Y,",") 46 ;I Y'=% D BMES^XPDUTL(" Not a production UCI") Q "" 47 ; 486/GMB Replaced the above 3 lines with the following line: 48 I '$$PROD^XUPROD D BMES^XPDUTL(" Not a production UCI") Q 0 49 Q 1 50 REMEDY ;Send to Remedy Server - ESSRESOURCE@MED.VA.GOV *p350 -REM 51 Q:'XPDTRACK 52 N XMY,XPDTEXT,XMTEXT,XMDUZ,XMSUB,XMZ 53 K ^TMP($J) 54 S:XPY XMY("ESSRESOURCE@MED.VA.GOV")=""55 S:$L($P(XPY,U,2)) XMY($P(XPY,U,2))="" 56 ;Message for server (all in one string) 57 ;XMTEXT=Type(1),Domain(2-65),Pkg(66-95),Version(96-125), 58 ; StartTime(126-147),CompleteTime(148-169),RunTime(170-177), 59 ; Date(178-199),InstalledBy(200-229),InstallName(230-259), 60 ; DistributionDate(260-281),Seq#(282-286), 61 ; PatchTestVersion(287-317)62 ; 63 S X1=1_$G(^XMB("NETNAME")) ;Type is always "1"(1=patch,0=pkg). 64 S $E(X1,66,95)=XPD,$E(X1,96,125)=XPDV,$E(X1,126,147)=XPZ(1),$E(X1,148,169)=XPZ(2),$E(X1,170,177)=XPZ(3),$E(X1,178,199)=DT 65 S $E(X1,200,229)=$P($G(^VA(200,+$P(XPD0,U,11),0)),U),$E(X1,230,259)=$P(XPD0,U),$E(X1,260,281)=$P(XPD1,U,4),$E(X1,282,286)=$P(XPD6,U,2),$E(X1,287,317)=$P(XPD6,U) 66 S XPDTEXT(1,0)=X1 67 S XMDUZ=$S($P(XPD0,U,11):+$P(XPD0,U,11),1:.5),XMTEXT="XPDTEXT(",XMSUB="KIDS-"_$P(XPD0,U)_" INSTALLATION" 68 D ^XMD 69 Q 70 FORUM() ;send to Server on FORUM 71 Q:'XPDTRACK""72 N XMY,XPDTEXT,XMTEXT,XMDUZ,XMSUB,XMZ 73 K ^TMP($J) 74 S:XPY XMY("S.A5CSTS@FORUM.VA.GOV")="" 75 S:$L($P(XPY,U,2)) XMY($P(XPY,U,2))="" 76 ;Message for server 77 S XPDTEXT(1,0)="PACKAGE INSTALL" 78 S XPDTEXT(2,0)="SITE: "_$G(^XMB("NETNAME"))79 S XPDTEXT(3,0)="PACKAGE: "_XPD 80 S XPDTEXT(4,0)="VERSION: "_XPDV 81 S XPDTEXT(5,0)="Start time: "_XPZ(1) 82 S XPDTEXT(6,0)="Completion time: "_XPZ(2) 83 S XPDTEXT(7,0)="Run time: "_XPZ(3)84 S XPDTEXT(8,0)="DATE: "_DT 85 S XPDTEXT(9,0)="Installed by: "_$P($G(^VA(200,+$P(XPD0,U,11),0)),U) 86 S XPDTEXT(10,0)="Install Name: "_$P(XPD0,U) 87 S XPDTEXT(11,0)="Distribution Date: "_$P(XPD1,U,4)88 S XPDTEXT(12,0)=XPD2 89 S XMDUZ=$S($P(XPD0,U,11):+$P(XPD0,U,11),1:.5),XMTEXT="XPDTEXT(",XMSUB=$P(XPD0,U)_" INSTALLATION"90 91 Q "#"_$G(XMZ) 1 XPDIST ;SFISC/RSD - site tracking; 06/01/2006 2 ;;8.0;KERNEL;**66,108,185,233,350,393**;Jul 10, 1995;Build 12 3 ;Returns ""=failed, XMZ=sent 4 ;D0=ien in file 9.7, XPY=national site tracking^address(optional) 5 EN(D0,XPY) ;send message 6 N %,DIFROM,XPD,XPD0,XPD1,XPD2,XPDV,XPDTEXT,XPZ,XMDUZ,XMSUB,XMTEXT,XMY,XMZ,X,X1,Z,Y,XPD6 7 ;Get data needed 8 I '$D(^XPD(9.7,$G(D0),0)) D BMES^XPDUTL(" INSTALL file entry missing") Q "" 9 ;p350 -add node 6 for the Test# and Seq#. -REM 10 S XPD0=^XPD(9.7,D0,0),XPD1=$G(^(1)),XPD2=$G(^(2)),XPD6=$G(^(6)) 11 I '$P(XPD0,U,2) D BMES^XPDUTL(" No link to PACKAGE file") Q "" 12 S XPD=$P($G(^DIC(9.4,+$P(XPD0,U,2),0)),U),XPDV=$$VER^XPDUTL($P(XPD0,U)) 13 I XPD="" D BMES^XPDUTL(" PACKAGE file entry missing") Q "" 14 ;XPZ(1)=start, XPZ(2)=completion date/time, XPZ(3)=run time 15 S XPZ(1)=$P(XPD1,U),XPZ(2)=$P(XPD1,U,3),XPZ(3)=$$FMDIFF^XLFDT(XPZ(2),XPZ(1),3),XPZ(1)=$$FMTE^XLFDT(XPZ(1)),XPZ(2)=$$FMTE^XLFDT(XPZ(2)) 16 D LOCAL 17 D REMEDY ;p350 -REM 18 Q $$FORUM() 19 ; 20 ; 21 FORUM() ;send to Server on FORUM 22 K XMY,XPDTEXT ;393 23 Q:$G(XPY)="" "" 24 S:XPY XMY("S.A5CSTS@FORUM.VA.GOV")="" ;,XMY("ESSRESOURCE@MED.VA.GOV")="" 25 S:$L($P(XPY,U,2)) XMY($P(XPY,U,2))="" 26 K ^TMP($J) 27 ;Quit if not VA production primary domain 28 I $G(^XMB("NETNAME"))'[".VA.GOV" D BMES^XPDUTL(" Not a VA primary domain") Q "" 29 X ^%ZOSF("UCI") S %=^%ZOSF("PROD") 30 S:%'["," Y=$P(Y,",") 31 I Y'=% D BMES^XPDUTL(" Not a production UCI") Q "" 32 ;Message for server 33 S XPDTEXT(1,0)="PACKAGE INSTALL" 34 S XPDTEXT(2,0)="SITE: "_$G(^XMB("NETNAME")) 35 S XPDTEXT(3,0)="PACKAGE: "_XPD 36 S XPDTEXT(4,0)="VERSION: "_XPDV 37 S XPDTEXT(5,0)="Start time: "_XPZ(1) 38 S XPDTEXT(6,0)="Completion time: "_XPZ(2) 39 S XPDTEXT(7,0)="Run time: "_XPZ(3) 40 S XPDTEXT(8,0)="DATE: "_DT 41 S XPDTEXT(9,0)="Installed by: "_$P($G(^VA(200,+$P(XPD0,U,11),0)),U) 42 S XPDTEXT(10,0)="Install Name: "_$P(XPD0,U) 43 S XPDTEXT(11,0)="Distribution Date: "_$P(XPD1,U,4) 44 S XPDTEXT(12,0)=XPD2 45 S XMDUZ=$S($P(XPD0,U,11):+$P(XPD0,U,11),1:.5),XMTEXT="XPDTEXT(",XMSUB=$P(XPD0,U)_" INSTALLATION" 46 D ^XMD 47 Q "#"_$G(XMZ) 48 ; 49 LOCAL ;Send a message to local mail group 50 K ^TMP($J),XMY,XPDTEXT,XMTEXT 51 S X=$$MAILGRP^XPDUTL(XPD) Q:X="" 52 S XMY(X)="" D GETENV^%ZOSV 53 ;Message for users 54 S XPDTEXT(1,0)="PACKAGE INSTALL" 55 S XPDTEXT(2,0)="SITE: "_$G(^XMB("NETNAME")) 56 S XPDTEXT(3,0)="PACKAGE: "_XPD 57 S XPDTEXT(4,0)="VERSION: "_XPDV 58 S XPDTEXT(5,0)="Start time: "_XPZ(1) 59 S XPDTEXT(6,0)="Completion time: "_XPZ(2) 60 S XPDTEXT(7,0)="Environment: "_Y 61 S XPDTEXT(8,0)="Installed by: "_$P($G(^VA(200,+$P(XPD0,U,11),0)),U) 62 S XPDTEXT(9,0)="Install Name: "_$P(XPD0,U) 63 S XPDTEXT(10,0)="Distribution Date: "_$$FMTE^XLFDT($P(XPD1,U,4)) 64 S XMDUZ=$S($P(XPD0,U,11):+$P(XPD0,U,11),1:.5),XMTEXT="XPDTEXT(",XMSUB=$P(XPD0,U)_" INSTALLATION" 65 D ^XMD 66 Q 67 ; 68 REMEDY ;Send to Remedy Server - ESSRESOURCE@MED.VA.GOV *p350 -REM 69 K ^TMP($J),XMY,XPDTEXT,XMTEXT ;393 70 Q:$G(XPY)="" 71 S:XPY XMY("ESSRESOURCE@MED.VA.GOV")="" 72 S:$L($P(XPY,U,2)) XMY($P(XPY,U,2))="" 73 ;Quit if not VA production primary domain 74 I $G(^XMB("NETNAME"))'[".VA.GOV" D BMES^XPDUTL(" Not a VA primary domain") Q 75 X ^%ZOSF("UCI") S %=^%ZOSF("PROD") 76 S:%'["," Y=$P(Y,",") 77 I Y'=% D BMES^XPDUTL(" Not a production UCI") Q 78 ;Message for server (all in one string) 79 ;XMTEXT=Type(1),Domain(2-65),Pkg(66-95),Version(96-125), 80 ; StartTime(126-147),CompleteTime(148-169),RunTime(170-177), 81 ; Date(178-199),InstalledBy(200-229),InstallName(230-259), 82 ; DistributionDate(260-281),Seq#(282-286), 83 ; PatchTestVersion(287-317) 84 ; 85 S X1=1_$G(^XMB("NETNAME")) ;Type is always "1"(1=patch,0=pkg). 86 S $E(X1,66,95)=XPD,$E(X1,96,125)=XPDV,$E(X1,126,147)=XPZ(1),$E(X1,148,169)=XPZ(2),$E(X1,170,177)=XPZ(3),$E(X1,178,199)=DT 87 S $E(X1,200,229)=$P($G(^VA(200,+$P(XPD0,U,11),0)),U),$E(X1,230,259)=$P(XPD0,U),$E(X1,260,281)=$P(XPD1,U,4),$E(X1,282,286)=$P(XPD6,U,2),$E(X1,287,317)=$P(XPD6,U) 88 S XPDTEXT(1,0)=X1 89 S XMDUZ=$S($P(XPD0,U,11):+$P(XPD0,U,11),1:.5),XMTEXT="XPDTEXT(",XMSUB="KIDS-"_$P(XPD0,U)_" INSTALLATION" 90 D ^XMD 91 Q -
WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XPDTA.m
r613 r623 1 XPDTA ;SFISC/RSD - Build Actions for Kernel Files ;02/14/2006 2 ;;8.0;KERNEL;**15,44,58,131,229,393,498**;Jul 10, 1995;Build 13 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 Q 5 ;^XTMP("XPDT",XPDA,"KRN",FILE,DA) is the global root 6 ;DA=ien in ^XTMP,XPDNM=package name, XPDA=package ien in ^XPD(9.6, 7 OPT ;options 8 N %,%1,%2 9 ;if link, kill everything and just process the menu items 10 I XPDFL=2 D G OPTT 11 .S %=0 F S %=$O(^XTMP("XPDT",XPDA,"KRN",19,DA,%)) Q:'% K:%'=10 ^(%) 12 ;resolve Package (0;12), remove Creator (0;5) 13 S %=^XTMP("XPDT",XPDA,"KRN",19,DA,0),$P(%,U,12)=$$PT("^DIC(9.4)",$P(%,U,12)),$P(%,U,5)="" 14 ;resolve Help Frame (0;7), kill Permitted Devices (3.96;0) & queue node (200) 15 S $P(%,U,7)=$$PT("^DIC(9.2)",$P(%,U,7)),^XTMP("XPDT",XPDA,"KRN",19,DA,0)=% K ^(3.96),^(200) 16 ;resolve Server Bulletin (220;1), Server Mailgroup (220;3) 17 I $D(^XTMP("XPDT",XPDA,"KRN",19,DA,220)) S %=^(220),$P(%,U)=$$PT("^XMB(3.6)",+%),$P(%,U,3)=$$PT("^XMB(3.8)",$P(%,U,3)),^XTMP("XPDT",XPDA,"KRN",19,DA,220)=% 18 ;resolve RPC (RPC;0), must be type Broker 19 I $D(^XTMP("XPDT",XPDA,"KRN",19,DA,"RPC")) K:$P(^(0),U,4)'="B" ^("RPC") D 20 .;kill "B"=name x-ref, it will be re-indexed when installed 21 .K ^XTMP("XPDT",XPDA,"KRN",19,DA,"RPC","B") 22 .;loop thru RPCs and resolve (RPC;1) 23 .S %=0 F S %=$O(^XTMP("XPDT",XPDA,"KRN",19,DA,"RPC",%)) Q:'% S %1=$G(^(%,0)) D 24 ..S %2=$$PT("^XWB(8994)",+%1) 25 ..;if can't resolve then delete 26 ..I %2="" K ^XTMP("XPDT",XPDA,"KRN",19,DA,"RPC",%,0) Q 27 ..;save the RPC name 28 ..S $P(^XTMP("XPDT",XPDA,"KRN",19,DA,"RPC",%,0),U)=%2 29 .Q 30 OPTT ;Menus can only exist for options of type: menu,protocol,protocol menu, 31 ;extended action, limited, window suite 32 I "LMOQXZ"'[$P(^XTMP("XPDT",XPDA,"KRN",19,DA,0),U,4) K ^(10) Q 33 ;kill "B"=name, "C"=synonyms x-ref, it will be re-indexed when installed 34 K ^XTMP("XPDT",XPDA,"KRN",19,DA,10,"B"),^("C") 35 ;loop thru 10=Menus and resolve Menu (10;1), kill if it doesn't resolve 36 S %=0 F S %=$O(^XTMP("XPDT",XPDA,"KRN",19,DA,10,%)) Q:'% S %1=$G(^(%,0)) D 37 .S %2=$$PT("^DIC(19)",+%1) 38 .;items must be sent by themselves, check "B" x-ref 39 .I $L(%2),$D(^XPD(9.6,XPDA,"KRN",19,"NM","B",%2)) S ^XTMP("XPDT",XPDA,"KRN",19,DA,10,%,U)=%2 Q 40 .;if I couldn't resolve this option, then kill it 41 .K ^XTMP("XPDT",XPDA,"KRN",19,DA,10,%) 42 Q 43 ; 44 PRO ;protocols 45 N %,%1,%2 46 ;if link, kill everything and just process the menu items 47 I XPDFL=2 D G PROT 48 .S %=0 F S %=$O(^XTMP("XPDT",XPDA,"KRN",101,DA,%)) Q:'% K:%'=10 ^(%) 49 ;resolve Package (0;12), remove Creator (0;5) 50 S %=^XTMP("XPDT",XPDA,"KRN",101,DA,0),$P(%,U,12)=$$PT("^DIC(9.4)",$P(%,U,12)),$P(%,U,5)="" 51 ;kill under Menus (10), "B"=name, "C"=synonyms 52 S ^XTMP("XPDT",XPDA,"KRN",101,DA,0)=% 53 ;resolve File Link (5;1), its a variable pointer 54 S %=$P($G(^XTMP("XPDT",XPDA,"KRN",101,DA,5)),U),%1=$P(%,";",2) 55 I %,$D(@("^"_%1_+%_",0)")) S $P(^XTMP("XPDT",XPDA,"KRN",101,DA,5),U)=$P(^(0),U)_";"_%1 56 ;resolve HL7 fields, node 770 57 S %=$G(^XTMP("XPDT",XPDA,"KRN",101,DA,770)) I $L(%) D S ^XTMP("XPDT",XPDA,"KRN",101,DA,770)=% 58 .S $P(%,U)=$$PT("^HL(771)",$P(%,U)),$P(%,U,2)=$$PT("^HL(771)",$P(%,U,2)) 59 .S $P(%,U,3)=$$PT("^HL(771.2)",$P(%,U,3)),$P(%,U,11)=$$PT("^HL(771.2)",$P(%,U,11)) 60 .S $P(%,U,4)=$$PT("^HL(779.001)",$P(%,U,4)),$P(%,U,7)=$$PT("^HLCS(870)",$P(%,U,7)) 61 .S $P(%,U,8)=$$PT("^HL(779.003)",$P(%,U,8)),$P(%,U,9)=$$PT("^HL(779.003)",$P(%,U,9)) 62 .S $P(%,U,10)=$$PT("^HL(771.5)",$P(%,U,10)) 63 PROT ;loop thru 10=Menus and resolve Menu (10;1), kill if it doesn't resolve 64 ;kill under Menus (10), "B"=name, "C"=synonyms 65 I $D(^XTMP("XPDT",XPDA,"KRN",101,DA,10,0)) K ^("B"),^("C") 66 S %=0 F S %=$O(^XTMP("XPDT",XPDA,"KRN",101,DA,10,%)) Q:'% S %1=$G(^(%,0)) D 67 .;%2=.01 of Menu(protocol) 68 .S %2=$$PT("^ORD(101)",+%1) 69 .;Menu must also be sent by itself, check "B" x-ref 70 .I $L(%2),$D(^XPD(9.6,XPDA,"KRN",101,"NM","B",%2)) S ^XTMP("XPDT",XPDA,"KRN",101,DA,10,%,U)=%2,$P(^XTMP("XPDT",XPDA,"KRN",101,DA,10,%,0),U,4)=$$PT("^ORD(101)",$P(%1,U,4)) Q 71 .K ^XTMP("XPDT",XPDA,"KRN",101,DA,10,%) 72 ;If type is Event Driver and sending Subscribers (775) 73 I $P(^XTMP("XPDT",XPDA,"KRN",101,DA,0),U,4)="E" D 74 . ;kill Menu multiple and Subscriber x-ref "B"=name 75 . K ^XTMP("XPDT",XPDA,"KRN",101,DA,10),^(775,"B") 76 . ;loop thru 775=Subscribers and resolve pointer (775;1) 77 . S %=0 F S %=$O(^XTMP("XPDT",XPDA,"KRN",101,DA,775,%)) Q:'% S %1=$G(^(%,0)) D 78 .. ;%2=.01 of subscriber(protocol) 79 .. S %2=$$PT("^ORD(101)",+%1) 80 .. ;protocol must also be sent by itself, check "B" x-ref 81 .. I $L(%2),$D(^XPD(9.6,XPDA,"KRN",101,"NM","B",%2)) S ^XTMP("XPDT",XPDA,"KRN",101,DA,775,%,U)=%2 Q 82 .. K ^XTMP("XPDT",XPDA,"KRN",101,DA,775,%) 83 ;quit if no Access multiple 84 Q:'$D(^XTMP("XPDT",XPDA,"KRN",101,DA,3,0)) K ^("B") 85 ;loop thru Access and resolve (3;1), kill if it doesn't resolve 86 S %=0 F S %=$O(^XTMP("XPDT",XPDA,"KRN",101,DA,3,%)) Q:'% S %1=$G(^(%,0)) D 87 .;%2=.01 of Menu(protocol) 88 .S %2=$$PT("^DIC(19.1)",+%1) 89 .I $L(%2) S ^XTMP("XPDT",XPDA,"KRN",101,DA,3,%,0)=%2 Q 90 .K ^XTMP("XPDT",XPDA,"KRN",101,DA,3,%) 91 Q 92 ; 93 RTNE ;routine entry build action 94 N %,X,XPD 95 ;move routine to ^XTMP("XPDT",DPK1,"RTN",routine name 96 ;routines will have the checksum in XTMP("XPDT",XPDA,"RTN",X) & in 97 ;Build file 98 S X=$P(^XTMP("XPDT",XPDA,"KRN",9.8,DA,0),U),XPD=^(-1) 99 Q:X="" S %=$$LOAD(X,XPD),$P(^XPD(9.6,XPDA,"KRN",9.8,"NM",+$P(XPD,U,2),0),U,4)=% 100 K ^XTMP("XPDT",XPDA,"KRN",9.8,DA) 101 Q 102 ; 103 RTNF ;routine file build action 104 N X,Y,% S Y=0 105 ;the routines that are left in XTMP("XPDT",XPDA,"KRN",9.8) are to be 106 ;deleted at site, move name field to RTN node 107 F S Y=$O(^XTMP("XPDT",XPDA,"KRN",9.8,Y)) Q:'Y S %=^(Y,-1),X=^(0) D 108 .I +%=1 S ^XTMP("XPDT",XPDA,"RTN",X)=%,^("RTN")=$G(^XTMP("XPDT",XPDA,"RTN"))+1 109 ;kill everything 110 K ^XTMP("XPDT",XPDA,"KRN",9.8) 111 Q 112 ; 113 PT(GR,DA) ;GR=file global ref, DA=ien, return .01 value 114 Q:'DA "" 115 Q:GR="" "" 116 I $D(@GR@(+DA,0))#2 Q $P(^(0),U) 117 Q "" 118 ; 119 GR(FN) ;returns closed global root, FN=file number 120 N Y 121 Q:'$G(FN) "" 122 S Y=$G(^DIC(FN,0,"GL")) Q:Y="" "" 123 Q $E(Y,1,($L(Y)-1))_$S($L(Y,",")>1:")",1:"") 124 ; 125 LOAD(X,XPD) ;load routine X, XPD=action^ien in Build file 126 ;XPD = 0-load, 1-delete, 2-skip, returns checksum 127 ;quit if routine is already saved 128 Q:$D(^XTMP("XPDT",XPDA,"RTN",X)) $P(^(X),U,3) 129 N DIF,XCNP,%N,%A,FDA,IEN,LN2 130 S DIF="^XTMP(""XPDT"",XPDA,""RTN"",X,",XCNP=0 131 X ^%ZOSF("LOAD") 132 S $P(^XTMP("XPDT",XPDA,"RTN",X,2,0),";",7)="Build "_(+^XPD(9.6,XPDA,6.3)),LN2=^XTMP("XPDT",XPDA,"RTN",X,2,0) 133 S IEN=$$FIND1^DIC(9.8,"","X",X) 134 ;^XTMP("XPDT",XPDA,"RTN",X)=action^ien in Build^checksum 135 S %N="B"_$$SUMB^XPDRSUM($NA(^XTMP("XPDT",XPDA,"RTN",X))) 136 S $P(XPD,"^",3)=%N ;Make sure the Checksum is in the 3rd piece 137 S ^XTMP("XPDT",XPDA,"RTN",X)=XPD 138 ;update count node 139 S ^("RTN")=$G(^XTMP("XPDT",XPDA,"RTN"))+1 140 N XUA,XUB S (XUA,XUB)="" 141 ;Update Dev Patch field in Routine file 142 I IEN D 143 . S XUB=$P(XPDT(XPDT),U,2) S:XUB["*" $P(XUB,"*",2)=+$P(XUB,"*",2) 144 . S IEN="?+2,"_IEN_",",FDA(9.819,IEN,.01)=XUB 145 . S FDA(9.819,IEN,2)=%N,FDA(9.819,IEN,3)=$P(LN2,";",5) 146 . D UPDATE^DIE("","FDA","IEN") 147 Q %N 1 XPDTA ;SFISC/RSD - Build Actions for Kernel Files ;02/14/2006 2 ;;8.0;KERNEL;**15,44,58,131,229,393**;Jul 10, 1995;Build 12 3 Q 4 ;^XTMP("XPDT",XPDA,"KRN",FILE,DA) is the global root 5 ;DA=ien in ^XTMP,XPDNM=package name, XPDA=package ien in ^XPD(9.6, 6 OPT ;options 7 N %,%1,%2 8 ;if link, kill everything and just process the menu items 9 I XPDFL=2 D G OPTT 10 .S %=0 F S %=$O(^XTMP("XPDT",XPDA,"KRN",19,DA,%)) Q:'% K:%'=10 ^(%) 11 ;resolve Package (0;12), remove Creator (0;5) 12 S %=^XTMP("XPDT",XPDA,"KRN",19,DA,0),$P(%,U,12)=$$PT("^DIC(9.4)",$P(%,U,12)),$P(%,U,5)="" 13 ;resolve Help Frame (0;7), kill Permitted Devices (3.96;0) & queue node (200) 14 S $P(%,U,7)=$$PT("^DIC(9.2)",$P(%,U,7)),^XTMP("XPDT",XPDA,"KRN",19,DA,0)=% K ^(3.96),^(200) 15 ;resolve Server Bulletin (220;1), Server Mailgroup (220;3) 16 I $D(^XTMP("XPDT",XPDA,"KRN",19,DA,220)) S %=^(220),$P(%,U)=$$PT("^XMB(3.6)",+%),$P(%,U,3)=$$PT("^XMB(3.8)",$P(%,U,3)),^XTMP("XPDT",XPDA,"KRN",19,DA,220)=% 17 ;resolve RPC (RPC;0), must be type Broker 18 I $D(^XTMP("XPDT",XPDA,"KRN",19,DA,"RPC")) K:$P(^(0),U,4)'="B" ^("RPC") D 19 .;kill "B"=name x-ref, it will be re-indexed when installed 20 .K ^XTMP("XPDT",XPDA,"KRN",19,DA,"RPC","B") 21 .;loop thru RPCs and resolve (RPC;1) 22 .S %=0 F S %=$O(^XTMP("XPDT",XPDA,"KRN",19,DA,"RPC",%)) Q:'% S %1=$G(^(%,0)) D 23 ..S %2=$$PT("^XWB(8994)",+%1) 24 ..;if can't resolve then delete 25 ..I %2="" K ^XTMP("XPDT",XPDA,"KRN",19,DA,"RPC",%,0) Q 26 ..;save the RPC name 27 ..S $P(^XTMP("XPDT",XPDA,"KRN",19,DA,"RPC",%,0),U)=%2 28 .Q 29 OPTT ;Menus can only exist for options of type: menu,protocol,protocol menu, 30 ;extended action, limited, window suite 31 I "LMOQXZ"'[$P(^XTMP("XPDT",XPDA,"KRN",19,DA,0),U,4) K ^(10) Q 32 ;kill "B"=name, "C"=synonyms x-ref, it will be re-indexed when installed 33 K ^XTMP("XPDT",XPDA,"KRN",19,DA,10,"B"),^("C") 34 ;loop thru 10=Menus and resolve Menu (10;1), kill if it doesn't resolve 35 S %=0 F S %=$O(^XTMP("XPDT",XPDA,"KRN",19,DA,10,%)) Q:'% S %1=$G(^(%,0)) D 36 .S %2=$$PT("^DIC(19)",+%1) 37 .;items must be sent by themselves, check "B" x-ref 38 .I $L(%2),$D(^XPD(9.6,XPDA,"KRN",19,"NM","B",%2)) S ^XTMP("XPDT",XPDA,"KRN",19,DA,10,%,U)=%2 Q 39 .;if I couldn't resolve this option, then kill it 40 .K ^XTMP("XPDT",XPDA,"KRN",19,DA,10,%) 41 Q 42 PRO ;protocols 43 N %,%1,%2 44 ;if link, kill everything and just process the menu items 45 I XPDFL=2 D G PROT 46 .S %=0 F S %=$O(^XTMP("XPDT",XPDA,"KRN",101,DA,%)) Q:'% K:%'=10 ^(%) 47 ;resolve Package (0;12), remove Creator (0;5) 48 S %=^XTMP("XPDT",XPDA,"KRN",101,DA,0),$P(%,U,12)=$$PT("^DIC(9.4)",$P(%,U,12)),$P(%,U,5)="" 49 ;kill under Menus (10), "B"=name, "C"=synonyms 50 S ^XTMP("XPDT",XPDA,"KRN",101,DA,0)=% 51 ;resolve File Link (5;1), its a variable pointer 52 S %=$P($G(^XTMP("XPDT",XPDA,"KRN",101,DA,5)),U),%1=$P(%,";",2) 53 I %,$D(@("^"_%1_+%_",0)")) S $P(^XTMP("XPDT",XPDA,"KRN",101,DA,5),U)=$P(^(0),U)_";"_%1 54 ;resolve HL7 fields, node 770 55 S %=$G(^XTMP("XPDT",XPDA,"KRN",101,DA,770)) I $L(%) D S ^XTMP("XPDT",XPDA,"KRN",101,DA,770)=% 56 .S $P(%,U)=$$PT("^HL(771)",$P(%,U)),$P(%,U,2)=$$PT("^HL(771)",$P(%,U,2)) 57 .S $P(%,U,3)=$$PT("^HL(771.2)",$P(%,U,3)),$P(%,U,11)=$$PT("^HL(771.2)",$P(%,U,11)) 58 .S $P(%,U,4)=$$PT("^HL(779.001)",$P(%,U,4)),$P(%,U,7)=$$PT("^HLCS(870)",$P(%,U,7)) 59 .S $P(%,U,8)=$$PT("^HL(779.003)",$P(%,U,8)),$P(%,U,9)=$$PT("^HL(779.003)",$P(%,U,9)) 60 .S $P(%,U,10)=$$PT("^HL(771.5)",$P(%,U,10)) 61 PROT ;loop thru 10=Menus and resolve Menu (10;1), kill if it doesn't resolve 62 ;kill under Menus (10), "B"=name, "C"=synonyms 63 I $D(^XTMP("XPDT",XPDA,"KRN",101,DA,10,0)) K ^("B"),^("C") 64 S %=0 F S %=$O(^XTMP("XPDT",XPDA,"KRN",101,DA,10,%)) Q:'% S %1=$G(^(%,0)) D 65 .;%2=.01 of Menu(protocol) 66 .S %2=$$PT("^ORD(101)",+%1) 67 .;Menu must also be sent by itself, check "B" x-ref 68 .I $L(%2),$D(^XPD(9.6,XPDA,"KRN",101,"NM","B",%2)) S ^XTMP("XPDT",XPDA,"KRN",101,DA,10,%,U)=%2,$P(^XTMP("XPDT",XPDA,"KRN",101,DA,10,%,0),U,4)=$$PT("^ORD(101)",$P(%1,U,4)) Q 69 .K ^XTMP("XPDT",XPDA,"KRN",101,DA,10,%) 70 ;If type is Event Driver and sending Subscribers (775) 71 I $P(^XTMP("XPDT",XPDA,"KRN",101,DA,0),U,4)="E" D 72 . ;kill Menu multiple and Subscriber x-ref "B"=name 73 . K ^XTMP("XPDT",XPDA,"KRN",101,DA,10),^(775,"B") 74 . ;loop thru 775=Subscribers and resolve pointer (775;1) 75 . S %=0 F S %=$O(^XTMP("XPDT",XPDA,"KRN",101,DA,775,%)) Q:'% S %1=$G(^(%,0)) D 76 .. ;%2=.01 of subscriber(protocol) 77 .. S %2=$$PT("^ORD(101)",+%1) 78 .. ;protocol must also be sent by itself, check "B" x-ref 79 .. I $L(%2),$D(^XPD(9.6,XPDA,"KRN",101,"NM","B",%2)) S ^XTMP("XPDT",XPDA,"KRN",101,DA,775,%,U)=%2 Q 80 .. K ^XTMP("XPDT",XPDA,"KRN",101,DA,775,%) 81 ;quit if no Access multiple 82 Q:'$D(^XTMP("XPDT",XPDA,"KRN",101,DA,3,0)) K ^("B") 83 ;loop thru Access and resolve (3;1), kill if it doesn't resolve 84 S %=0 F S %=$O(^XTMP("XPDT",XPDA,"KRN",101,DA,3,%)) Q:'% S %1=$G(^(%,0)) D 85 .;%2=.01 of Menu(protocol) 86 .S %2=$$PT("^DIC(19.1)",+%1) 87 .I $L(%2) S ^XTMP("XPDT",XPDA,"KRN",101,DA,3,%,0)=%2 Q 88 .K ^XTMP("XPDT",XPDA,"KRN",101,DA,3,%) 89 Q 90 RTNE ;routine entry build action 91 N %,X,XPD 92 ;move routine to ^XTMP("XPDT",DPK1,"RTN",routine name 93 ;routines will have the checksum in XTMP("XPDT",XPDA,"RTN",X) & in 94 ;Build file 95 S X=$P(^XTMP("XPDT",XPDA,"KRN",9.8,DA,0),U),XPD=^(-1) 96 Q:X="" S %=$$LOAD(X,XPD),$P(^XPD(9.6,XPDA,"KRN",9.8,"NM",+$P(XPD,U,2),0),U,4)=% 97 K ^XTMP("XPDT",XPDA,"KRN",9.8,DA) 98 Q 99 RTNF ;routine file build action 100 N X,Y,% S Y=0 101 ;the routines that are left in XTMP("XPDT",XPDA,"KRN",9.8) are to be 102 ;deleted at site, move name field to RTN node 103 F S Y=$O(^XTMP("XPDT",XPDA,"KRN",9.8,Y)) Q:'Y S %=^(Y,-1),X=^(0) D 104 .I +%=1 S ^XTMP("XPDT",XPDA,"RTN",X)=%,^("RTN")=$G(^XTMP("XPDT",XPDA,"RTN"))+1 105 ;kill everything 106 K ^XTMP("XPDT",XPDA,"KRN",9.8) 107 Q 108 PT(GR,DA) ;GR=file global ref, DA=ien, return .01 value 109 Q:'DA "" 110 I $D(@GR@(+DA,0))#2 Q $P(^(0),U) 111 Q "" 112 ; 113 LOAD(X,XPD) ;load routine X, XPD=action^ien in Build file 114 ;XPD = 0-load, 1-delete, 2-skip, returns checksum 115 ;quit if routine is already saved 116 Q:$D(^XTMP("XPDT",XPDA,"RTN",X)) $P(^(X),U,3) 117 N DIF,XCNP,%N,%A,FDA,IEN,LN2 118 S DIF="^XTMP(""XPDT"",XPDA,""RTN"",X,",XCNP=0 119 X ^%ZOSF("LOAD") 120 S $P(^XTMP("XPDT",XPDA,"RTN",X,2,0),";",7)="Build "_(+^XPD(9.6,XPDA,6.3)),LN2=^XTMP("XPDT",XPDA,"RTN",X,2,0) 121 S IEN=$$FIND1^DIC(9.8,"","X",X) 122 ;^XTMP("XPDT",XPDA,"RTN",X)=action^ien in Build^checksum 123 S %N="B"_$$SUMB^XPDRSUM($NA(^XTMP("XPDT",XPDA,"RTN",X))) 124 S $P(XPD,"^",3)=%N ;Make sure the Checksum is in the 3rd piece 125 S ^XTMP("XPDT",XPDA,"RTN",X)=XPD 126 ;update count node 127 S ^("RTN")=$G(^XTMP("XPDT",XPDA,"RTN"))+1 128 N XUA,XUB S (XUA,XUB)="" 129 ;Update Dev Patch field in Routine file 130 I IEN D 131 . S XUB=$P(XPDT(XPDT),U,2) S:XUB["*" $P(XUB,"*",2)=+$P(XUB,"*",2) 132 . S IEN="?+2,"_IEN_",",FDA(9.819,IEN,.01)=XUB 133 . S FDA(9.819,IEN,2)=%N,FDA(9.819,IEN,3)=$P(LN2,";",5) 134 . D UPDATE^DIE("","FDA","IEN") 135 Q %N -
WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XPDTA2.m
r613 r623 1 XPDTA2 ;SFISC/RWF - Build Actions for Kernel Files Cont. ;08/09/2001 12:36 2 ;;8.0;KERNEL;**201,498**;Jul 10, 1995;Build 13 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 Q 5 ;^XTMP("XPDT",XPDA,"KRN",XPDFILE,DA) is the global root 6 ;DA=ien in ^XTMP,XPDNM=package name, XPDA=package ien in ^XPD(9.6, 7 ; 8 PAR1E1 ;PARAMETER file 8989.51: entry post 9 N XP,XP1,XP2,XP3,XP4,VP,PN,PT,ROOT 10 S ROOT=$NA(^XTMP("XPDT",XPDA,"KRN")) 11 D PAR51(DA) ;Handle the entry from 8989.51 12 S PT=$S($E($G(^XTV(8989.51,DA,1)))="P":$P(^(1),U,2),1:"") ;Data Type & Value - check if pointer in for loop 13 S:PT]"" PT=$S(PT:$$GR^XPDTA(PT),1:"") ;PT=file # of pointed to file from parm def. 14 ;Now find any entrys in 8989.5 to transport, because we point to them 15 S XP=0,XP3=$P(^XPD(9.6,XPDA,0),U,2),VP=XP3_";DIC(9.4,",PN=$$PT^XPDTA("^DIC(9.4)",XP3) 16 Q:'XP3 ;No package file link 17 F S XP=$O(^XTV(8989.5,"AC",DA,VP,XP)),XP1=0 Q:'XP D ;Instance 18 . F S XP1=$O(^XTV(8989.5,"AC",DA,VP,XP,XP1)) Q:'XP1 D ;entry 19 . . M ^XTMP("XPDT",XPDA,"KRN",8989.5,XP1)=^XTV(8989.5,XP1) 20 . . S XP3=^XTV(8989.5,XP1,0),XP4=$G(^(1)) ;param def. 21 . . S $P(@ROOT@(8989.5,XP1,0),U,2)=$$PT^XPDTA("^XTV(8989.51)",$P(XP3,U,2)) 22 . . I PT]"",XP4>0 S $P(@ROOT@(8989.5,XP1,1),U)=$$PT^XPDTA(PT,XP4) ;Data Type pointer - resolve 23 . . Q ;Will redo the ENT at other end. 24 Q 25 ; 26 PAR51(DA) ;Fix one 8989.51 entry in transport global 27 ;Called from both PAR1E1 and PAR2E1 28 N XP,XP1,XP2,XP3,VP,PN,ROOT 29 S ROOT=$NA(^XTMP("XPDT",XPDA,"KRN")) 30 ;Don't bring X-ref 31 K @ROOT@(8989.51,DA,30,"B"),^("AG") 32 S XP=0 33 ;Entries in the file will be maintained by Toolkit patches. 34 Q 35 ; 36 PAR2E1 ;PARAMETER file 8989.52 entry post 37 N XP1,XP2,XP3,ROOT 38 S ROOT=$NA(^XTMP("XPDT",XPDA,"KRN")) 39 ;Resolve USE INSTANCE OF 40 S XP2=$P(^XTV(8989.52,DA,0),U,4),XP3="" I XP2 S XP3=$$PT^XPDTA($NA(^XTV(8989.51)),XP2) 41 I $L(XP3) S $P(@ROOT@(8989.52,DA,0),U,4)=XP3 42 ;Resolve PARAMETERS 43 S XP1=0 K ^XTMP("XPDT",XPDA,"KRN",8989.52,DA,10,"B") ;Drop X-ref 44 F S XP1=$O(^XTV(8989.52,DA,10,XP1)),XP3="" Q:'XP1 D 45 . S XP2=$P(^XTV(8989.52,DA,10,XP1,0),U,2) 46 . I XP2 S XP3=$$PT^XPDTA($NA(^XTV(8989.51)),XP2) 47 . I '$L(XP3) K @ROOT@(8989.52,DA,10,XP1) 48 . S $P(^XTMP("XPDT",XPDA,"KRN",8989.52,DA,10,XP1,0),U,2)=XP3 49 . ;Now to move the entries this points to. 50 . I '$D(@ROOT@(8989.51,XP2)) M @ROOT@(8989.51,XP2)=^XTV(8989.51,XP2) D PAR51(XP2) 51 . Q 52 Q 1 XPDTA2 ;SFISC/RWF - Build Actions for Kernel Files Cont. ;08/09/2001 12:36 2 ;;8.0;KERNEL;**201**;Jul 10, 1995 3 Q 4 ;^XTMP("XPDT",XPDA,"KRN",XPDFILE,DA) is the global root 5 ;DA=ien in ^XTMP,XPDNM=package name, XPDA=package ien in ^XPD(9.6, 6 ; 7 PAR1E1 ;PARAMETER file 8989.51: entry post 8 N XP,XP1,XP2,XP3,VP,PN,ROOT 9 S ROOT=$NA(^XTMP("XPDT",XPDA,"KRN")) 10 D PAR51(DA) ;Handle the entry from 8989.51 11 ;Now find any entrys in 8989.5 to transport, because we point to them 12 S XP=0,XP3=$P(^XPD(9.6,XPDA,0),U,2),VP=XP3_";DIC(9.4,",PN=$$PT^XPDTA("^DIC(9.4)",XP3) 13 Q:'XP3 ;No package file link 14 F S XP=$O(^XTV(8989.5,"AC",DA,VP,XP)),XP1=0 Q:'XP D ;Instance 15 . F S XP1=$O(^XTV(8989.5,"AC",DA,VP,XP,XP1)) Q:'XP1 D ;entry 16 . . M ^XTMP("XPDT",XPDA,"KRN",8989.5,XP1)=^XTV(8989.5,XP1) 17 . . S XP3=^XTV(8989.5,XP1,0) ;param def. 18 . . S $P(@ROOT@(8989.5,XP1,0),U,2)=$$PT^XPDTA("^XTV(8989.51)",$P(XP3,U,2)) 19 . . Q ;Will redo the ENT at other end. 20 Q 21 ; 22 PAR51(DA) ;Fix one 8989.51 entry in transport global 23 ;Called from both PAR1E1 and PAR2E1 24 N XP,XP1,XP2,XP3,VP,PN,ROOT 25 S ROOT=$NA(^XTMP("XPDT",XPDA,"KRN")) 26 ;Don't bring X-ref 27 K @ROOT@(8989.51,DA,30,"B"),^("AG") 28 S XP=0 29 ;Entries in the file will be maintained by Toolkit patches. 30 Q 31 ; 32 PAR2E1 ;PARAMETER file 8989.52 entry post 33 N XP1,XP2,XP3,ROOT 34 S ROOT=$NA(^XTMP("XPDT",XPDA,"KRN")) 35 ;Resolve USE INSTANCE OF 36 S XP2=$P(^XTV(8989.52,DA,0),U,4),XP3="" I XP2 S XP3=$$PT^XPDTA($NA(^XTV(8989.51)),XP2) 37 I $L(XP3) S $P(@ROOT@(8989.52,DA,0),U,4)=XP3 38 ;Resolve PARAMETERS 39 S XP1=0 K ^XTMP("XPDT",XPDA,"KRN",8989.52,DA,10,"B") ;Drop X-ref 40 F S XP1=$O(^XTV(8989.52,DA,10,XP1)),XP3="" Q:'XP1 D 41 . S XP2=$P(^XTV(8989.52,DA,10,XP1,0),U,2) 42 . I XP2 S XP3=$$PT^XPDTA($NA(^XTV(8989.51)),XP2) 43 . I '$L(XP3) K @ROOT@(8989.52,DA,10,XP1) 44 . S $P(^XTMP("XPDT",XPDA,"KRN",8989.52,DA,10,XP1,0),U,2)=XP3 45 . ;Now to move the entries this points to. 46 . I '$D(@ROOT@(8989.51,XP2)) M @ROOT@(8989.51,XP2)=^XTV(8989.51,XP2) D PAR51(XP2) 47 . Q 48 Q -
WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQ3.m
r613 r623 1 XQ3 ;LL/THM,SF/GJL,SEA/JLI - CLEANUP DANGLING POINTERS IN OPTION OR HELP FRAME FILES ;04/30/08 17:06 2 ;;8.0;KERNEL;**80,501**;Jul 10, 1995;Build 1 3 Q 4 ENASK ;Ask to fix up dirty OPTION/HELP FRAME File 5 N IX,XUT,J,K,XQFL,X 6 I '$D(%) W !,$C(7),"ENTRY MUST BE WITH THE VARIABLE '%' SET TO INDICATE DESIRED FILE.",$C(7),! Q 7 S XQFL=$S(%=1:"OPTION",%=2:"PROTOCOL",1:"HELP FRAME") 8 W !,"Do you want to remove any 'Dangling Pointers' from your ",XQFL," File? Y// " R X:$S($D(DTIME):DTIME,1:300) I '$T Q 9 W ! I X="" S X="Y" 10 I X["?" G SYNTAX 11 I X["^" S X="^" Q 12 STRIP I X'="",X'?1A.E S X=$E(X,2,256) G STRIP 13 S X=$E(X,1) I X="" G SYNTAX 14 I "Nn"[X S X="N" Q 15 I "Yy"[X W !,"PLEASE WAIT while I check this out . . . " G REMOVE 16 SYNTAX W ! I X'["?" W ?11,"I'm sorry, but I don't understand your answer. Please" 17 W !,"Enter: YES (or press the RETURN key) if you want me to remove from" 18 W !,?11,"your ",XQFL," File any pointers left over from incompletely" 19 W !,?11,"deleted ",XQFL,". If such pointers do exist and are not" 20 W !,?11,"removed, the ",XQFL," File (i.e. the menus) could become" 21 W !,?11,"messed up by an INIT." 22 W !!,"Enter: NO or ^ to continue on without effecting the ",XQFL," File." 23 W ! G ENASK 24 REMOVE D:%=1 OPFIX D:%=2 PFIX D:'% HFFIX W !,"Your ",XQFL," File is OK " I 'XUT W "(no bad pointers)." 25 E W "now (",XUT," pointer" W:XUT>1 "s" W " fixed)." 26 W ! S X="Y" 27 Q 28 OPFIX ;Kill any dangling pointers in the OPTION File (#19) 29 N %,IX,J,XQ3 30 S (IX,XUT)=0 ;XUT=Total Deletions 31 F S IX=$O(^DIC(19,IX)) Q:'IX W:'(IX#100) ". " S (XQ3,J)=0 D L2 ;Loop through Options 32 D NPF 33 Q 34 L2 ;One Option 35 I '$D(^DIC(19,IX,10,0)) Q ;Not a Menu 36 K ^DIC(19,IX,10,"B") ;Rebuild "B" X-ref 37 F S J=$O(^DIC(19,IX,10,J)) Q:'J D ITEM ;Loop through menu items 38 S (K,J)=0 F S J=$O(^DIC(19,IX,10,J)) Q:J'>0 S K=J ;K=Last item 39 S J=^DIC(19,IX,10,0),^(0)=$P(J,"^",1,2)_"^"_K_"^"_XQ3 ;fix counters 40 Q 41 ; 42 ITEM ;One Menu item 43 N DA,DIK 44 S K=+^DIC(19,IX,10,J,0) 45 I $D(^DIC(19,K,0)) S XQ3=XQ3+1,^DIC(19,IX,10,"B",K,J)="" Q ;Y=No. of items 46 W !,"Option ",$P(^DIC(19,IX,0),U,1)," points to missing option ",K 47 ;S XUT=XUT+1 K ^DIC(19,IX,10,J) ;Kill invalid menu item 48 S XUT=XUT+1,DIK="^DIC(19,DA(1),10,",DA=J,DA(1)=IX D ^DIK ;Trigger Menu-rebuild 49 Q 50 ; 51 NPF ;Fix the New Person File Option Pointers 52 N IX,I2,J,P,DIK,DIE,DR,DA,XUT 53 S (XUT,IX)=0 54 F S IX=$O(^VA(200,IX)) Q:'IX D 55 . S P=+$G(^VA(200,IX,201)) 56 . I P,'$D(^DIC(19,P,0)) D 57 . . W !,"User: ",$P(^VA(200,IX,0),U),", Primary Menu points to missing option ",P 58 . . S XUT=XUT+1,DIE="^VA(200,",DA=IX,DR="201///@" D ^DIE 59 . . Q 60 . S I2=0 61 . F S I2=$O(^VA(200,IX,203,I2)) Q:'I2 D 62 . . S P=+$G(^VA(200,IX,203,I2,0)) 63 . . I P,'$D(^DIC(19,P,0)) D 64 . . . W !,"User: ",$P(^VA(200,IX,0),U),", Secondary Menu points to missing option ",P 65 . . . S XUT=XUT+1,DIK="^VA(200,DA(1),203,",DA=I2,DA(1)=IX D ^DIK 66 . . . Q 67 . . Q 68 . Q 69 I XUT W !,"Menu pointers fixed." 70 Q 71 HFFIX ; Fix dangling pointers on help frame file 72 N % 73 S (XUT,IX)=0 F S IX=$O(^DIC(9.2,IX)) Q:IX'>0 I $D(^(IX,2)) D HF1,HF2,HF3 74 Q 75 HF1 S (Y,J)=0 F S J=$O(^DIC(9.2,IX,2,J)) Q:J'>0 I $D(^(J,0)) S K=$P(^(0),U,2),Y=Y+1 I $L(K),'$D(^DIC(9.2,K)) S Y=Y-1,XUT=XUT+1 K ^DIC(9.2,IX,2,J,0) 76 Q 77 HF2 S (K,J)=0 F S J=$O(^DIC(9.2,IX,2,J)) Q:J'>0 S K=J 78 S J=^DIC(9.2,IX,2,0),^(0)=$P(J,U,1,2)_U_K_U_Y 79 Q 80 HF3 S K=":" F S K=$O(^DIC(9.2,IX,2,K)) Q:K="" S J=-1 F S J=$O(^DIC(9.2,IX,2,K,J)) Q:J="" D HF4 81 Q 82 HF4 S JJ=0 F S JJ=$O(^DIC(9.2,IX,2,K,J,JJ)) Q:JJ'>0 I '$D(^DIC(9.2,IX,2,JJ,0)) K ^DIC(9.2,IX,2,K,J,JJ) 83 Q 84 PFIX ;Kill any dangling pointers in the PROTOCOL File (#101) 85 N % 86 S (IX,XUT)=0 ;XUT=Total Deletions 87 P1 S IX=$O(^ORD(101,IX)) I IX>0 S (Y,J)=0 G P2 ;Loop through protocols 88 Q 89 P2 S J=$O(^ORD(101,IX,10,J)) I J>0 G PITEM ;Loop through items 90 I '$D(^ORD(101,IX,10,0)) G P1 91 S (K,J)=0 F L=1:1 S J=$O(^ORD(101,IX,10,J)) Q:J'>0 S K=J ;K=Last item 92 S J=^ORD(101,IX,10,0),^(0)=$P(J,"^",1,2)_"^"_K_"^"_Y ;fix counters 93 G PXREFS 94 PITEM S K=+^ORD(101,IX,10,J,0) I $D(^ORD(101,K,0)) S Y=Y+1 G P2 ;Y=No. of items 95 W !,"Protocol ",$P(^ORD(101,IX,0),U,1)," points to missing protocol ",K 96 ;S XUT=XUT+1 K ^ORD(101,IX,10,J) ;Kill invalid menu item 97 S XUT=XUT+1,DIK="^ORD(101,IX,10,",DA=J,DA(1)=IX D ^DIK ;Delete invalid menu item 98 G P2 99 PXREFS S K=":" 100 P3 S K=$O(^ORD(101,IX,10,K)) I K="" G P1 ;Loop through cross references 101 S L=-1 102 P4 S L=$O(^ORD(101,IX,10,K,L)) I L="" G P3 103 S J=0 104 P5 S J=$O(^ORD(101,IX,10,K,L,J)) I J'>0 G P4 105 I '$D(^ORD(101,IX,10,J,0)) G PKILLXR ;kill xref to invalid item 106 P6 S M=^ORD(101,IX,10,J,0) I (M=L)!(M[L_"^") G P5 107 PKILLXR K ^ORD(101,IX,10,K,L,J) I $O(^ORD(101,IX,10,K,L,-1))="" K ^ORD(101,IX,10,K,L) 108 G P5 1 XQ3 ;LL/THM,SF/GJL,SEA/JLI - CLEANUP DANGLING POINTERS IN OPTION OR HELP FRAME FILES ;04/21/98 13:20 2 ;;8.0;KERNEL;**80**;Jul 10, 1995 3 Q 4 ENASK ;Ask to fix up dirty OPTION/HELP FRAME File 5 I '$D(%) W !,$C(7),"ENTRY MUST BE WITH THE VARIABLE '%' SET TO INDICATE DESIRED FILE.",$C(7),! Q 6 S XQFL=$S(%=1:"OPTION",%=2:"PROTOCOL",1:"HELP FRAME") 7 W !,"Do you want to remove any 'Dangling Pointers' from your ",XQFL," File? Y// " R X:$S($D(DTIME):DTIME,1:300) I '$T Q 8 W ! I X="" S X="Y" 9 I X["?" G SYNTAX 10 I X["^" S X="^" Q 11 STRIP I X'="",X'?1A.E S X=$E(X,2,256) G STRIP 12 S X=$E(X,1) I X="" G SYNTAX 13 I "Nn"[X S X="N" Q 14 I "Yy"[X W !,"PLEASE WAIT while I check this out . . . " G REMOVE 15 SYNTAX W ! I X'["?" W ?11,"I'm sorry, but I don't understand your answer. Please" 16 W !,"Enter: YES (or press the RETURN key) if you want me to remove from" 17 W !,?11,"your ",XQFL," File any pointers left over from incompletely" 18 W !,?11,"deleted ",XQFL,". If such pointers do exist and are not" 19 W !,?11,"removed, the ",XQFL," File (i.e. the menus) could become" 20 W !,?11,"messed up by an INIT." 21 W !!,"Enter: NO or ^ to continue on without effecting the ",XQFL," File." 22 W ! G ENASK 23 REMOVE D:%=1 ENFIX D:%=2 PFIX D:'% HFFIX W !,"Your ",XQFL," File is OK " I 'X W "(no bad pointers)." 24 E W "now (",X," pointer" W:X>1 "s" W " fixed)." 25 W ! S X="Y" Q 26 ENFIX ;Kill any dangling pointers in the OPTION File (#19) 27 S (I,X)=0 ;X=Total Deletions 28 L1 S I=$O(^DIC(19,I)) I I>0 S (Y,J)=0 G L2 ;Loop through menus 29 Q 30 L2 S J=$O(^DIC(19,I,10,J)) I J>0 G ITEM ;Loop through menu items 31 I '$D(^DIC(19,I,10,0)) G L1 32 S (K,J)=0 F L=1:1 S J=$O(^DIC(19,I,10,J)) Q:J'>0 S K=J ;K=Last item 33 S J=^DIC(19,I,10,0),^(0)=$P(J,"^",1,2)_"^"_K_"^"_Y ;fix counters 34 G XREFS 35 ITEM S K=+^DIC(19,I,10,J,0) I $D(^DIC(19,K,0)) S Y=Y+1 G L2 ;Y=No. of items 36 W !,"Option ",$P(^DIC(19,I,0),U,1)," points to missing option ",K 37 S X=X+1 K ^DIC(19,I,10,J) ;Kill invalid menu item 38 G L2 39 XREFS S K=":" 40 L3 S K=$O(^DIC(19,I,10,K)) I K="" G L1 ;Loop through cross references 41 S L=-1 42 L4 S L=$O(^DIC(19,I,10,K,L)) I L="" G L3 43 S J=0 44 L5 S J=$O(^DIC(19,I,10,K,L,J)) I J'>0 G L4 45 I '$D(^DIC(19,I,10,J,0)) G KILLXR ;kill xref to invalid item 46 L6 S M=^DIC(19,I,10,J,0) I (M=L)!(M[L_"^") G L5 47 KILLXR K ^DIC(19,I,10,K,L,J) I $O(^DIC(19,I,10,K,L,-1))="" K ^DIC(19,I,10,K,L) 48 G L5 49 HFFIX ; Fix dangling pointers on help frame file 50 S (X,I)=0 F S I=$O(^DIC(9.2,I)) Q:I'>0 I $D(^(I,2)) D HF1,HF2,HF3 51 Q 52 HF1 S (Y,J)=0 F S J=$O(^DIC(9.2,I,2,J)) Q:J'>0 I $D(^(J,0)) S K=$P(^(0),U,2),Y=Y+1 I $L(K),'$D(^DIC(9.2,K)) S Y=Y-1,X=X+1 K ^DIC(9.2,I,2,J,0) 53 Q 54 HF2 S (K,J)=0 F S J=$O(^DIC(9.2,I,2,J)) Q:J'>0 S K=J 55 S J=^DIC(9.2,I,2,0),^(0)=$P(J,U,1,2)_U_K_U_Y 56 Q 57 HF3 S K=":" F S K=$O(^DIC(9.2,I,2,K)) Q:K="" S J=-1 F S J=$O(^DIC(9.2,I,2,K,J)) Q:J="" D HF4 58 Q 59 HF4 S JJ=0 F S JJ=$O(^DIC(9.2,I,2,K,J,JJ)) Q:JJ'>0 I '$D(^DIC(9.2,I,2,JJ,0)) K ^DIC(9.2,I,2,K,J,JJ) 60 Q 61 PFIX ;Kill any dangling pointers in the PROTOCOL File (#101) 62 S (I,X)=0 ;X=Total Deletions 63 P1 S I=$O(^ORD(101,I)) I I>0 S (Y,J)=0 G P2 ;Loop through protocols 64 Q 65 P2 S J=$O(^ORD(101,I,10,J)) I J>0 G PITEM ;Loop through items 66 I '$D(^ORD(101,I,10,0)) G P1 67 S (K,J)=0 F L=1:1 S J=$O(^ORD(101,I,10,J)) Q:J'>0 S K=J ;K=Last item 68 S J=^ORD(101,I,10,0),^(0)=$P(J,"^",1,2)_"^"_K_"^"_Y ;fix counters 69 G PXREFS 70 PITEM S K=+^ORD(101,I,10,J,0) I $D(^ORD(101,K,0)) S Y=Y+1 G P2 ;Y=No. of items 71 W !,"Option ",$P(^ORD(101,I,0),U,1)," points to missing option ",K 72 S X=X+1 K ^ORD(101,I,10,J) ;Kill invalid menu item 73 G P2 74 PXREFS S K=":" 75 P3 S K=$O(^ORD(101,I,10,K)) I K="" G P1 ;Loop through cross references 76 S L=-1 77 P4 S L=$O(^ORD(101,I,10,K,L)) I L="" G P3 78 S J=0 79 P5 S J=$O(^ORD(101,I,10,K,L,J)) I J'>0 G P4 80 I '$D(^ORD(101,I,10,J,0)) G PKILLXR ;kill xref to invalid item 81 P6 S M=^ORD(101,I,10,J,0) I (M=L)!(M[L_"^") G P5 82 PKILLXR K ^ORD(101,I,10,K,L,J) I $O(^ORD(101,I,10,K,L,-1))="" K ^ORD(101,I,10,K,L) 83 G P5 -
WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQ5.m
r613 r623 1 XQ5 ;SF/GFT,MJM,KLD - Menu edit utilities [XUEDITOPT] ;01/30/2008 2 ;;8.0;KERNEL;**44,130,484**;Jul 10, 1995;Build 2 3 ; Per VHA Directive 2004-038, this routine should not be modified. 4 ; Option & Input Template: XUEDITOPT 5 DIP ; 6 K DIC S DIC=.4,DIC(0)="AEQMZ" I $D(^DIC(19,DA,63)),^(63)?1"[".E1"]" S DIC("B")=$E(^(63),2,$L(^(63))-1) 7 S DUZ0=$S(DUZ(0)="@"!$D(^XUSEC("XUMGR",DUZ)):1,1:0) G:DUZ0 DIP1 S DIC("S")="I 1 Q:'$D(^DIC(+$P(^(0),U,4),0,""RD"")) F %=1:1:$L(^(""RD"")) I DUZ(0)[$E(^(""RD""),%) Q" 8 DIP1 ; 9 D:$G(DUZ0) PRNT 10 D ^DIC K DIC G:Y<0&(DUZ(0)'="@") Q G:Y<0&(DUZ0) Q1 S XQDIC=+$P(Y(0),U,4) G:XQDIC'>1 Q S XQ=$P(^DIC(XQDIC,0),U,1)_U_XQDIC,XQ(63)="["_$P(Y,U,2)_"]",XQ(60)=$P(^(0,"GL"),U,2),XQ(62)=0 11 BY ; 12 D:$G(DUZ0) SORT 13 K DIC S DIC=.401,DIC(0)="AEQMZ" I $D(^DIC(19,DA,64)),^(64)?1"[".E1"]" S DIC("B")=$E(^(64),2,$L(^(64))-1) 14 S DIC("S")="I $P(^(0),U,4)=XQDIC" G:DUZ0 BY1 S DIC("S")=DIC("S")_" Q:'$D(^DIC(+$P(^(0),U,4),0,""RD"")) F %=1:1:$L(^(""RD"")) I DUZ(0)[$E(^(""RD""),%) Q" 15 BY1 ; 16 D ^DIC K DIC G TEM:X="",Q:Y<0 S XQDIC=+$P(Y(0),U,4),XQ=$P(^DIC(XQDIC,0),U,1)_U_XQDIC,XQ(64)="["_$P(Y,U,2)_"]" G FR 17 TEM ; 18 I +X=X,'$D(^DD(+$P(XQ,U,2),X,0)) W *7,"NO SUCH FIELD NUMBER" K X G BY 19 S XQ(64)=X 20 FR K X S Y=$S($D(^DIC(19,DA,65)):^(65),1:"") W !,"START WITH: ",$S(Y]"":Y,1:"FIRST")_"// " R X:DTIME G:X=U Q S:X="" X=Y W:X="?" !?4,"ENTER IN 'FR' FORMAT" G:X="?" FR K:X="@" X,^DIC(19,DA,65) W:'$D(X) *7," DELETED!" S:$D(X) XQ(65)=X 21 TO K X S Y=$S($D(^DIC(19,DA,66)):^(66),1:"") W !,"GO TO: ",$S(Y]"":Y,1:"LAST")_"// " R X:DTIME G:X=U Q S:X="" X=Y W:X="?" !?4,"ENTER IN 'TO' FORMAT" G:X="?" TO K:X="@" X,^DIC(19,DA,66) W:'$D(X) *7," DELETED!" S:$D(X) XQ(66)=X 22 D PUT G Q1 23 DIE ; 24 S DUZ0=$S(DUZ(0)="@"!$D(^XUSEC("XUMGR",DUZ)):1,1:0) 25 K DIC,XQ S DIC=.402,DIC(0)="AQEMZ" I $D(^DIC(19,DA,51)),^(51)?1"[".E1"]" S DIC("B")=$E(^(51),2,$L(^(51))-1) 26 G:DUZ0 DIE1 S DIC("S")="I 1 Q:'$D(^DIC(+$P(^(0),U,4),0,""WR"")) F %=1:1:$L(^(""WR"")) I DUZ(0)[$E(^(""WR""),%) Q" 27 DIE1 ; 28 D ^DIC K DIC G:Y<0&(DUZ(0)'="@") Q G:Y<0&(DUZ0) Q1 S XQDIC="",XQDIC=+$P(Y(0),U,4) G:'XQDIC Q S XQ(51)="["_$P(Y,U,2)_"]" D DIC S XQ(50)=XQ(30) D PUT G Q1 29 PUT S X=0 F S X=$O(XQ(X)) Q:X'>0 S ^DIC(19,DA,X)=XQ(X) 30 Q 31 ; 32 Q W *7,!,"NO CHANGE MADE TO OPTION LOGIC" 33 Q1 K XQDIC,XQ,Y S DIC=DIE Q 34 ; 35 DIC S XQ=$P(^DIC(XQDIC,0),U,1),XQ(30)=$P(^(0,"GL"),U,2) 36 S XQ(31)=$G(^DIC(19,DA,31)) S:XQ(31)="" XQ(31)="AEMQ" 37 I $D(^DIC(XQDIC,0,"LAYGO")),DUZ(0)'="@" S Y=$L(^("LAYGO")) I Y F %=1:1 I DUZ(0)[$E(^("LAYGO"),%) G A:%>Y Q 38 W !,"WHEN USER SELECTS AN ENTRY IN THE '"_XQ_"' FILE,",!,"WILL ADDING A NEW ENTRY AT THAT TIME ('LAYGO') BE ALLOWED" 39 S %=$S(XQ(31)["L":0,1:2) D YN^DICN 40 I %=1 I XQ(31)'["L" S XQ(31)=XQ(31)_"L" 41 I %=2 I XQ(31)["L" S XQ(31)=$TR(XQ(31),"L") 42 A Q 43 ; 44 DIQ ; 45 S DUZ0=$S(DUZ(0)="@"!$D(^XUSEC("XUMGR",DUZ)):1,1:0) 46 K DIC,XQ S DIC=1,DIC(0)="AEQMZ",DIC("A")="INQUIRE TO WHAT FILE: " 47 I $D(^DIC(19,DA,30)),^(30)["(",@("$D(^"_^(30)_"0))") S DIC("B")=+$P(^(0),U,2) 48 G:DUZ0 DIQ1 S DIC("S")="I 1 Q:'$D(^(0,""RD"")) F %=1:1:$L(^(""RD"")) I DUZ(0)[$E(^(""RD""),%) Q" 49 DIQ1 ; 50 D ^DIC K DIC G:Y<0 Q S (XQ(80),XQ(30))=$P(^(0,"GL"),U,2) 51 S XQ(31)=$G(^DIC(19,DA,31)) S:XQ(31)="" XQ(31)="AEMQ" 52 D PUT G Q1 53 ; 54 NAME ; 55 I $E(X,1)="A"!($E(X,1)="Z") S %=1,%1="Local" Q 56 F %=4:-1:2 G:$D(^DIC(9.4,"C",$E(X,1,%))) NAMEOK 57 I 0 58 Q 59 NAMEOK S %1=$O(^DIC(9.4,"C",$E(X,1,%),0)) S:%1="" %1=-1 S:$D(^DIC(9.4,%1,0)) %1=$P(^(0),U,1),XQPK=%1 I 1 Q 60 ; 61 CHKNAME ;Called from the input transform of the .01 field of the Option File 62 Q:$D(DIFROM)!($D(ZTQUEUED)) K XQPK 63 I $D(DIC(0))#2,DIC(0)'["E" Q 64 D NAME E D EN^DDIOL("Not a known package or a local namespace.") Q 65 D EN^DDIOL(" Located in the "_$E(X,1,%)_" ("_%1_") namespace.") Q 66 ; 67 PRNT W !,?16,"*** IMPORTANT PLEASE READ ***",! 68 W !,"By selecting a new Print/Sort Template below, your defaults will" 69 W !,"be changed. Your defaults are currently set as follows (see below)." 70 W !,"Should you desire to keep the defaults as they are, or to revise" 71 W !,"one or more, enter an '^' up-arrow, without selecting a new" 72 W !,"template name." 73 W !!,?23,"Default Values",!,?23,"==============",! 74 W !,?5,"DIC {DIP}: "_$$GET1^DIQ(19,DA,60) 75 W ?40,"L.: "_$$GET1^DIQ(19,DA,62) 76 W !,?5,"FLDS: "_$$GET1^DIQ(19,DA,63) 77 W ?40,"BY: "_$$GET1^DIQ(19,DA,64) 78 W !,?5,"FR: "_$$GET1^DIQ(19,DA,65) 79 W ?40,"TO: "_$$GET1^DIQ(19,DA,66),!! 80 Q 81 ; 82 SORT W !,?16,"*** IMPORTANT PLEASE READ ***",! 83 W !,"By selecting a new Sort Template below, your defaults will be" 84 W !,"changed. Your defaults are currently set as follows (see below)." 85 W !,"Should you desire to keep the defaults as they are, or to revise" 86 W !,"one or more, enter an '^' up-arrow, without selecting a new Sort" 87 W !,"Template." 88 W !!,?23,"Default Values",!,?23,"==============",! 89 W ?5,"BY: "_$$GET1^DIQ(19,DA,64) 90 W !,?5,"FR: "_$$GET1^DIQ(19,DA,65) 91 W ?40,"TO: "_$$GET1^DIQ(19,DA,66),!! 92 Q 93 TEST W !,"Enter a name, and the computer will respond with the namespace to which",!,"that name belongs. It does this by looking at the package file.",!! 94 T1 R !,"NAME: ",X:DTIME," " Q:X="" D CHKNAME G T1 95 CLEAR ;Clear fields not used by this option. 96 I "EMPRSOQ"[X X "F %="_$S("M"[X:"25,27:1:82","QO"[X:"25,31:1:82","RS"[X:"10,30:1:82","E"[X:"10,25,60:1:82","P"[X:"10,25,27:1:54,80:1:82")_" I $D(^DIC(19,DA,%)) D:%=10 CLEAR1 K ^DIC(19,DA,%)" 97 I "AI"[X X "F %="_$S("A"[X:"10,25,30:1:82","I"[X:"10,25,36:1:62,64:1:73")_" I $D(^DIC(19,DA,%)) D:%=10 CLEAR1 K ^DIC(19,DA,%)" 98 I "OQ"'[X F %=100,100.1,100.2 I $D(^DIC(19,DA,%)) K ^DIC(19,DA,%) 99 Q 100 CLEAR1 S XQI=0 F S XQI=$O(^DIC(19,DA,%,XQI)) Q:XQI'>0 S XQJ=$P(^(XQI,0),U) K ^DIC(19,"AD",$E(XQJ,1,30),DA,XQI) 101 K XQI,XQJ 102 Q 1 XQ5 ;SF/GFT,MJM,KLD - Menu edit utilities [XUEDITOPT] ;09/20/96 15:33 2 ;;8.0;KERNEL;**44,130**;Jul 10, 1995 3 DIP ; 4 K DIC S DIC=.4,DIC(0)="AEQMZ" I $D(^DIC(19,DA,63)),^(63)?1"[".E1"]" S DIC("B")=$E(^(63),2,$L(^(63))-1) 5 S DUZ0=$S(DUZ(0)="@"!$D(^XUSEC("XUMGR",DUZ)):1,1:0) G:DUZ0 DIP1 S DIC("S")="I 1 Q:'$D(^DIC(+$P(^(0),U,4),0,""RD"")) F %=1:1:$L(^(""RD"")) I DUZ(0)[$E(^(""RD""),%) Q" 6 DIP1 ; 7 D:$G(DUZ0) PRNT 8 D ^DIC K DIC G:Y<0&(DUZ(0)'="@") Q G:Y<0&(DUZ0) Q1 S XQDIC=+$P(Y(0),U,4) G:XQDIC'>1 Q S XQ=$P(^DIC(XQDIC,0),U,1)_U_XQDIC,XQ(63)="["_$P(Y,U,2)_"]",XQ(60)=$P(^(0,"GL"),U,2),XQ(62)=0 9 BY ; 10 D:$G(DUZ0) SORT 11 K DIC S DIC=.401,DIC(0)="AEQMZ" I $D(^DIC(19,DA,64)),^(64)?1"[".E1"]" S DIC("B")=$E(^(64),2,$L(^(64))-1) 12 S DIC("S")="I $P(^(0),U,4)=XQDIC" G:DUZ0 BY1 S DIC("S")=DIC("S")_" Q:'$D(^DIC(+$P(^(0),U,4),0,""RD"")) F %=1:1:$L(^(""RD"")) I DUZ(0)[$E(^(""RD""),%) Q" 13 BY1 ; 14 D ^DIC K DIC G TEM:X="",Q:Y<0 S XQDIC=+$P(Y(0),U,4),XQ=$P(^DIC(XQDIC,0),U,1)_U_XQDIC,XQ(64)="["_$P(Y,U,2)_"]" G FR 15 TEM ; 16 I +X=X,'$D(^DD(+$P(XQ,U,2),X,0)) W *7,"NO SUCH FIELD NUMBER" K X G BY 17 S XQ(64)=X 18 FR K X S Y=$S($D(^DIC(19,DA,65)):^(65),1:"") W !,"START WITH: ",$S(Y]"":Y,1:"FIRST")_"// " R X:DTIME G:X=U Q S:X="" X=Y W:X="?" !?4,"ENTER IN 'FR' FORMAT" G:X="?" FR K:X="@" X,^DIC(19,DA,65) W:'$D(X) *7," DELETED!" S:$D(X) XQ(65)=X 19 TO K X S Y=$S($D(^DIC(19,DA,66)):^(66),1:"") W !,"GO TO: ",$S(Y]"":Y,1:"LAST")_"// " R X:DTIME G:X=U Q S:X="" X=Y W:X="?" !?4,"ENTER IN 'TO' FORMAT" G:X="?" TO K:X="@" X,^DIC(19,DA,66) W:'$D(X) *7," DELETED!" S:$D(X) XQ(66)=X 20 D PUT G Q1 21 DIE ; 22 S DUZ0=$S(DUZ(0)="@"!$D(^XUSEC("XUMGR",DUZ)):1,1:0) 23 K DIC,XQ S DIC=.402,DIC(0)="AQEMZ" I $D(^DIC(19,DA,51)),^(51)?1"[".E1"]" S DIC("B")=$E(^(51),2,$L(^(51))-1) 24 G:DUZ0 DIE1 S DIC("S")="I 1 Q:'$D(^DIC(+$P(^(0),U,4),0,""WR"")) F %=1:1:$L(^(""WR"")) I DUZ(0)[$E(^(""WR""),%) Q" 25 DIE1 ; 26 D ^DIC K DIC G:Y<0&(DUZ(0)'="@") Q G:Y<0&(DUZ0) Q1 S XQDIC="",XQDIC=+$P(Y(0),U,4) G:'XQDIC Q S XQ(51)="["_$P(Y,U,2)_"]" D DIC S XQ(50)=XQ(30) D PUT G Q1 27 PUT S X=0 F S X=$O(XQ(X)) Q:X'>0 S ^DIC(19,DA,X)=XQ(X) 28 Q 29 ; 30 Q W *7,!,"NO CHANGE MADE TO OPTION LOGIC" 31 Q1 K XQDIC,XQ,Y S DIC=DIE Q 32 ; 33 DIC S XQ=$P(^DIC(XQDIC,0),U,1),XQ(30)=$P(^(0,"GL"),U,2),XQ(31)="AEMQ" 34 I $D(^DIC(XQDIC,0,"LAYGO")),DUZ(0)'="@" S Y=$L(^("LAYGO")) I Y F %=1:1 I DUZ(0)[$E(^("LAYGO"),%) G A:%>Y Q 35 W !,"WHEN USER SELECTS AN ENTRY IN THE '"_XQ_"' FILE,",!,"WILL ADDING A NEW ENTRY AT THAT TIME ('LAYGO') BE ALLOWED" 36 S %=$S($D(^DIC(19,DA,31)):^(31)'["L"+1,1:0) D YN^DICN I %=1 S XQ(31)="AEMQL" 37 A Q 38 ; 39 DIQ ; 40 S DUZ0=$S(DUZ(0)="@"!$D(^XUSEC("XUMGR",DUZ)):1,1:0) 41 K DIC,XQ S DIC=1,DIC(0)="AEQMZ",DIC("A")="INQUIRE TO WHAT FILE: " 42 I $D(^DIC(19,DA,30)),^(30)["(",@("$D(^"_^(30)_"0))") S DIC("B")=+$P(^(0),U,2) 43 G:DUZ0 DIQ1 S DIC("S")="I 1 Q:'$D(^(0,""RD"")) F %=1:1:$L(^(""RD"")) I DUZ(0)[$E(^(""RD""),%) Q" 44 DIQ1 ; 45 D ^DIC K DIC G:Y<0 Q S XQ(31)="AEMQ",(XQ(80),XQ(30))=$P(^(0,"GL"),U,2) D PUT G Q1 46 ; 47 NAME ; 48 I $E(X,1)="A"!($E(X,1)="Z") S %=1,%1="Local" Q 49 F %=4:-1:2 G:$D(^DIC(9.4,"C",$E(X,1,%))) NAMEOK 50 I 0 51 Q 52 NAMEOK S %1=$O(^DIC(9.4,"C",$E(X,1,%),0)) S:%1="" %1=-1 S:$D(^DIC(9.4,%1,0)) %1=$P(^(0),U,1),XQPK=%1 I 1 Q 53 ; 54 CHKNAME ;Called from the input transform of the .01 field of the Option File 55 Q:$D(DIFROM)!($D(ZTQUEUED)) K XQPK 56 I $D(DIC(0))#2,DIC(0)'["E" Q 57 D NAME E D EN^DDIOL("Not a known package or a local namespace.") Q 58 D EN^DDIOL(" Located in the "_$E(X,1,%)_" ("_%1_") namespace.") Q 59 ; 60 PRNT W !,?16,"*** IMPORTANT PLEASE READ ***",! 61 W !,"By selecting a new Print/Sort Template below, your defaults will" 62 W !,"be changed. Your defaults are currently set as follows(see below)." 63 W !,"Should you desire to keep the defaults as they are, or to revise" 64 W !,"one or more, enter an '^' up-arrow, without selecting a new" 65 W !,"template name." 66 W !!,?23,"Default Values",!,?23,"==============",! 67 W !,?17,"DIC {DIP}: "_$$GET1^DIQ(19,DA,60) 68 W ?40,"L.: "_$$GET1^DIQ(19,DA,62) 69 W !,?17,"FLDS: "_$$GET1^DIQ(19,DA,63) 70 W ?40,"BY: "_$$GET1^DIQ(19,DA,64) 71 W !,?17,"FR: "_$$GET1^DIQ(19,DA,65) 72 W ?40,"TO: "_$$GET1^DIQ(19,DA,66),!! 73 Q 74 ; 75 SORT W !,?16,"*** IMPORTANT PLEASE READ ***",! 76 W !,"By selecting a new Sort Template below, your defaults will be" 77 W !,"changed. Your defaults are currently set as follow(see below)." 78 W !,"Should you desire to keep the defaults as they are, or to revise" 79 W !,"one or more, enter an '^' up-arrow, without selecting a new Sort" 80 W !,"Template." 81 W !!,?23,"Default Values",!,?23,"==============",! 82 W ?17,"BY: "_$$GET1^DIQ(19,DA,64) 83 W !,?17,"FR: "_$$GET1^DIQ(19,DA,65) 84 W ?40,"TO: "_$$GET1^DIQ(19,DA,66),!! 85 Q 86 TEST W !,"Enter a name, and the computer will respond with the namespace to which",!,"that name belongs. It does this by looking at the package file.",!! 87 T1 R !,"NAME: ",X:DTIME," " Q:X="" D CHKNAME G T1 88 CLEAR ;Clear fields not used by this option. 89 I "EMPRSOQ"[X X "F %="_$S("M"[X:"25,27:1:82","QO"[X:"25,31:1:82","RS"[X:"10,30:1:82","E"[X:"10,25,60:1:82","P"[X:"10,25,27:1:54,80:1:82")_" I $D(^DIC(19,DA,%)) D:%=10 CLEAR1 K ^DIC(19,DA,%)" 90 I "AI"[X X "F %="_$S("A"[X:"10,25,30:1:82","I"[X:"10,25,36:1:62,64:1:73")_" I $D(^DIC(19,DA,%)) D:%=10 CLEAR1 K ^DIC(19,DA,%)" 91 I "OQ"'[X F %=100,100.1,100.2 I $D(^DIC(19,DA,%)) K ^DIC(19,DA,%) 92 Q 93 CLEAR1 S XQI=0 F S XQI=$O(^DIC(19,DA,%,XQI)) Q:XQI'>0 S XQJ=$P(^(XQI,0),U) K ^DIC(19,"AD",$E(XQJ,1,30),DA,XQI) 94 K XQI,XQJ 95 Q -
WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQ55.m
r613 r623 1 XQ55 ; SEA/AMF,MJM,JLI - SEARCH FOR USERS ACCESS TO AN OPTION; 2 ;;8.0;KERNEL;**140,342,483,508**;Jul 10, 1995;Build 1 3 ;;Per VHA Directive 2004-038, this routine should not be modified 4 INIT ; 5 S XQDSH="-------------------------------------------------------------------------------" 6 D ^XQDATE S XQDT=%Y 7 OPT W ! S DIC=19,DIC(0)="AEQM" D ^DIC G:Y=-1 OUT S XQOPT=+Y 8 MPAT W !!,"Show menu paths" S %=2 D YN^DICN G:%<0 OUT S XQMP=2-% I '% W !!,"If you answer 'YES', the listing will include the menu path(s) each user has",!,"to access the specified option." G MPAT 9 K ^TMP($J),XQR,XQP 10 S K=^DIC(19,XQOPT,0),XQHDR="Access to '"_$P(K,U,2)_"' ["_$P(K,U,1)_"]",XQSCD=0,XQCOM=0,XQNOPRNT=0 11 LOOP1 S K=XQOPT,(L,X(0))=0,XQD=K K XQR,XQA,XQK,XQRV S XQR(K)="" I '$L($P(^DIC(19,K,0),U,3)) D TREE1 12 G LOOP2 13 Q 14 TREE S X(L)=$O(^DIC(19,"AD",XQD,X(L))) Q:X(L)'>0 S K=X(L) G:$D(XQR(K)) TREE S XQR(K)="" 15 TREE1 ; 16 S Y(0)=^DIC(19,K,0) G:$L($P(Y(0),U,3)) TREE S:$L($P(Y(0),U,6)) XQK(L)=$P(Y(0),U,6) S XQA(L)=K I $P(Y(0),U,16) S XQRV(L)=^DIC(19,K,3) 17 D SETGLO S L=L+1,X(L)=0,(XQD,XQD(L))=K D TREE 18 Q:L=1 K XQR(XQD(L)) S L=L-1 K XQA(L),XQK(L),XQRV(L) S XQD=XQD(L) G TREE 19 Q 20 SETGLO ; 21 S XQK="" F I=L:-1:0 I $D(XQK(I)),$L(XQK(I)) S XQK=XQK_XQK(I)_"," 22 S XQRV="" F I=L:-1:0 I $D(XQRV(I)),$L(XQRV(I)) S XQRV=XQRV_XQRV(I)_"," 23 S XQA="" F I=L:-1:1 I $D(XQA(I)) S XQA=XQA_XQA(I)_"," 24 S XQA=XQA_XQOPT,J=0 S:$D(^TMP($J,K,0)) J=^(0) S J=J+1,^(0)=J,^TMP($J,K,J)=XQK_U_XQA_U_XQRV 25 Q 26 LOOP2 ; 27 S XQPA(0)=0,XQP=0 F S XQP=$O(^TMP($J,XQP)) Q:XQP="" S XQN=^TMP($J,XQP,0) S XQPS="AP" D USERS S XQPS="AD" D USERS 28 D USERS1 I XQNOPRNT G MUS ; 080115 - add in options from the common menu 29 G LOOP3 30 USERS ; 31 S XQU=0 F S XQU=$O(^VA(200,XQPS,XQP,XQU)) Q:XQU'>0 I $D(^VA(200,XQU,.1)),+$$ACTIVE^XUSER(XQU) D EACHU 32 Q 33 USERS1 ; 080115 code added to handle options on the COMMON (XUCOMMAND) menu 34 N XUCOMMON 35 S XUCOMMON=$O(^DIC(19,"B","XUCOMMAND",0)) 36 S XQP=0 F S XQP=$O(^TMP($J,XQP)) Q:XQP="" S XQN=^TMP($J,XQP,0) F J=1:1:XQN Q:'$D(^TMP($J,XQP,J)) I $P($P(^TMP($J,XQP,J),U,2),",")=XUCOMMON D 37 . D Q:'Y 38 . . W !,"***" 39 . . W !,"*** This option is available from the 'SYSTEM COMMAND OPTIONS' ***" 40 . . W !,"*** (XUCOMMAND) menu available to all active users unless ***" 41 . . W !,"*** protected by a KEY - DO YOU REALLY WANT THE ENTIRE LIST ***" 42 . . W !,"*** OF THESE USERS??? ***",! 43 . . N DIR S DIR(0)="Y" D ^DIR S:'Y XQNOPRNT=1 Q:'Y 44 . . Q 45 . S XQU=0,XQPS="(C)" F S XQU=$O(^VA(200,XQU)) Q:XQU'>0 I $D(^VA(200,XQU,.1)),+$$ACTIVE^XUSER(XQU),$$KEYCHECK() S II=1 D SETU 46 Q 47 ; 48 EACHU ; 49 S II=1 50 F J=1:1:XQN Q:'$D(^TMP($J,XQP,J)) I $$KEYCHECK() D SETU ; 080115 51 Q 52 ; 53 KEYCHECK() ; 080115 extracted common code 54 ; returns 1 if user has access to the option, 0 if the user does not have access 55 S XQK=$P(^TMP($J,XQP,J),U,1),XX=$L(XQK,",")-1,XQGO=1 56 I XX F X=1:1:XX S Y=$P(XQK,",",X) I Y'="",('$D(^XUSEC(Y,XQU))) S XQGO=0 57 S XQK=$P(^TMP($J,XQP,J),U,3),XX=$L(XQK,",")-1 58 I XX F X=1:1:XX S Y=$P(XQK,",",X) I Y'="",($D(^XUSEC(Y,XQU))) S XQGO=0 59 Q XQGO 60 ; 61 SETU ; 62 S XQPA=$P(^TMP($J,XQP,J),U,2) 63 I '$D(XQPA(XQPA)) S I=XQPA(0)+1,XQPA(0)=I,XQPA(0,I)=XQPA,XQPA(XQPA)=I 64 S XQPA=XQPA(XQPA) S:XQPS="AD" XQPA=XQPA_"(S)",XQSCD=1 S:XQPS="(C)" XQPA=XQPA_"(C)",XQCOM=1 ; 080115 65 S I=$P(^VA(200,XQU,0),U,1)_U_XQU S:$D(^TMP($J,0,I)) II=$O(^TMP($J,0,I,"A"),-1)+1 S ^TMP($J,0,I,II)=XQPA 66 Q 67 LOOP3 ; 68 I $O(^TMP($J,0,0))="" W !!,"** NO USERS CAN ACCESS THIS OPTION **" G OUT 69 S %ZIS="MFQ" D ^%ZIS G OUT:POP I $D(IO("Q")) K IO("Q") S ZTRTN="DQ^XQ55",ZTDESC="OPTION ACCESS BY USER",ZTSAVE("XQ*")="",ZTSAVE("^TMP($J,")="" D ^%ZTLOAD K ZTSK,ZTRTN,ZTSAVE,ZTDESC G OUT 70 ; 71 DQ ;Entry point for queued job 72 U IO 73 S:'XQMP XQPA(0)=-4 S XQPG=0,XQUI=0 D NEWPG G:XQUI MUS 74 S XQU=0 F S XQU=$O(^TMP($J,0,XQU)) Q:XQU="" D PRTU G:XQUI MUS 75 D:XQMP MENUPAT G MUS 76 NEWPG ; 77 S X="" I XQPG,$E(IOST,1)="C" D CON S XQUI=(X="^") Q:XQUI 78 D HDR Q 79 CON ; 80 W !!,"Press return to continue or '^' to escape " R X:DTIME S:'$T X=U 81 Q 82 HDR ; 83 W @IOF S XQPG=XQPG+1 84 W "Page ",XQPG,?62,XQDT,!! S XQTAB=(76-$L(XQHDR))/2 W ?XQTAB,XQHDR 85 W !!,"USER NAME",?27,"LAST ON",?37,"PRIMARY MENU" W:XQMP ?63,"PATH(S)" 86 W !,$E(XQDSH,1,25),?27,$E(XQDSH,1,8),?37,$E(XQDSH,1,$S(XQMP:24,1:40)) W:XQMP ?63,$E(XQDSH,1,14) 87 Q 88 PRTU ; 89 I $Y>(IOSL-XQPA(0)-8) D:XQMP MENUPAT D NEWPG Q:XQUI 90 S J=$P(XQU,U,2),K="" S:$D(^VA(200,J,1.1)) K=$P(^(1.1),"^") S:$L(K) K=$E(K,4,5)_"/"_$E(K,6,7)_"/"_$E(K,2,3) W !,$E($P(XQU,U,1),1,27),?27,K 91 I $D(^VA(200,J,201)) S K=+^(201) I K>0,$D(^DIC(19,K,0)) W ?37,$E($P(^(0),U,1),1,24) 92 I XQMP D 93 .W ?63,"" 94 .S JJ=$O(^TMP($J,0,XQU,"A"),-1) 95 .F II=1:1:JJ W $G(^TMP($J,0,XQU,II)) I II'=JJ W "," 96 I 'XQMP D 97 .S II=0 F S II=$O(^TMP($J,0,XQU,II)) Q:II'>0 D 98 ..I ^TMP($J,0,XQU,II)["(S)" W " (Secondary menu)" S II="A" 99 Q 100 MENUPAT ; 101 W !!,$E(XQDSH,1,27)," MENU PATH(S) ",$E(XQDSH,1,29),! 102 F I=1:1:XQPA(0) S K=XQPA(0,I) W !,I,".",?4 F N=1:1 Q:'$L($P(K,",",N)) W:N>1 " ... " W $P(^DIC(19,$P(K,",",N),0),U,1) 103 I XQSCD W !,"(S) - secondary menu pathway" 104 I XQCOM W !,"(C) - SYSTEM COMMAND OPTIONS (XUCOMMAND) menu pathway" 105 Q 106 MUS G:X="^" OUT I $G(XQPG),$E(IOST,1)="C" W !!,"Press return when finished viewing " R X:DTIME W @IOF G OUT 107 I $D(ZTSK) K ^%ZTSK(ZTSK) 108 OUT ; 109 D ^%ZISC 110 KILL K XQDT,XQGO,XQN,XQP,XQR,XQRV,XQOPT,XQPA,XQUI,XQSCD,XQDSH,XQU,N,K,J,X,XQA,XQD,XQHDR,XQK,XQP,XQPS,XQMP,XQPG,XX 111 K DIC,I,II,JJ,L,POP,Y,XQNOPRNT I $D(ZTQUEUED),$D(ZTSK),ZTSK>0 K ^%ZTSK(ZTSK) 112 Q 1 XQ55 ; SEA/AMF,MJM,JLI - SEARCH FOR USERS ACCESS TO AN OPTION [4/12/04 4:36am] 2 ;;8.0;KERNEL;**140,342**;Jul 10, 1995 3 INIT ; 4 S XQDSH="-------------------------------------------------------------------------------" 5 D ^XQDATE S XQDT=%Y 6 OPT W ! S DIC=19,DIC(0)="AEQM" D ^DIC G:Y=-1 OUT S XQOPT=+Y 7 MPAT W !!,"Show menu paths" S %=2 D YN^DICN G:%<0 OUT S XQMP=2-% I '% W !!,"If you answer 'YES', the listing will include the menu path(s) each user has",!,"to access the specified option." G MPAT 8 K ^TMP($J),XQR,XQP 9 S K=^DIC(19,XQOPT,0),XQHDR="Access to '"_$P(K,U,2)_"' ["_$P(K,U,1)_"]",XQSCD=0 10 LOOP1 S K=XQOPT,(L,X(0))=0,XQD=K K XQR,XQA,XQK,XQRV S XQR(K)="" I '$L($P(^DIC(19,K,0),U,3)) D TREE1 11 G LOOP2 12 Q 13 TREE S X(L)=$O(^DIC(19,"AD",XQD,X(L))) Q:X(L)'>0 S K=X(L) G:$D(XQR(K)) TREE S XQR(K)="" 14 TREE1 ; 15 S Y(0)=^DIC(19,K,0) G:$L($P(Y(0),U,3)) TREE S:$L($P(Y(0),U,6)) XQK(L)=$P(Y(0),U,6) S XQA(L)=K I $P(Y(0),U,16) S XQRV(L)=^DIC(19,K,3) 16 D SETGLO S L=L+1,X(L)=0,(XQD,XQD(L))=K D TREE 17 Q:L=1 K XQR(XQD(L)) S L=L-1 K XQA(L),XQK(L),XQRV(L) S XQD=XQD(L) G TREE 18 Q 19 SETGLO ; 20 S XQK="" F I=L:-1:0 I $D(XQK(I)),$L(XQK(I)) S XQK=XQK_XQK(I)_"," 21 S XQRV="" F I=L:-1:0 I $D(XQRV(I)),$L(XQRV(I)) S XQRV=XQRV_XQRV(I)_"," 22 S XQA="" F I=L:-1:1 I $D(XQA(I)) S XQA=XQA_XQA(I)_"," 23 S XQA=XQA_XQOPT,J=0 S:$D(^TMP($J,K,0)) J=^(0) S J=J+1,^(0)=J,^TMP($J,K,J)=XQK_U_XQA_U_XQRV 24 Q 25 LOOP2 ; 26 S XQPA(0)=0,XQP=0 F S XQP=$O(^TMP($J,XQP)) Q:XQP="" S XQN=^TMP($J,XQP,0) S XQPS="AP" D USERS S XQPS="AD" D USERS 27 G LOOP3 28 USERS ; 29 S XQU=0 F S XQU=$O(^VA(200,XQPS,XQP,XQU)) Q:XQU'>0 I $D(^VA(200,XQU,.1)),+$$ACTIVE^XUSER(XQU) D EACHU 30 Q 31 EACHU ; 32 S II=1 33 F J=1:1:XQN Q:'$D(^TMP($J,XQP,J)) D 34 .S XQK=$P(^TMP($J,XQP,J),U,1),XX=$L(XQK,",")-1,XQGO=1 35 .I XX F X=1:1:XX S Y=$P(XQK,",",X) I Y'="",('$D(^XUSEC(Y,XQU))) S XQGO=0 36 .S XQK=$P(^TMP($J,XQP,J),U,3),XX=$L(XQK,",")-1 37 .I XX F X=1:1:XX S Y=$P(XQK,",",X) I Y'="",($D(^XUSEC(Y,XQU))) S XQGO=0 38 .D:XQGO SETU 39 Q 40 SETU ; 41 S XQPA=$P(^TMP($J,XQP,J),U,2) 42 I '$D(XQPA(XQPA)) S I=XQPA(0)+1,XQPA(0)=I,XQPA(0,I)=XQPA,XQPA(XQPA)=I 43 S XQPA=XQPA(XQPA) S:XQPS="AD" XQPA=XQPA_"(S)",XQSCD=1 44 S I=$P(^VA(200,XQU,0),U,1)_U_XQU S:$D(^TMP($J,0,I)) II=$O(^TMP($J,0,I,"A"),-1)+1 S ^TMP($J,0,I,II)=XQPA 45 Q 46 LOOP3 ; 47 I $O(^TMP($J,0,0))="" W !!,"** NO USERS CAN ACCESS THIS OPTION **" G OUT 48 S %ZIS="MFQ" D ^%ZIS G OUT:POP I $D(IO("Q")) K IO("Q") S ZTRTN="DQ^XQ55",ZTDESC="OPTION ACCESS BY USER",ZTSAVE("XQ*")="",ZTSAVE("^TMP($J,")="" D ^%ZTLOAD K ZTSK,ZTRTN,ZTSAVE,ZTDESC G OUT 49 ; 50 DQ ;Entry point for queued job 51 U IO 52 S:'XQMP XQPA(0)=-4 S XQPG=0,XQUI=0 D NEWPG G:XQUI MUS 53 S XQU=0 F S XQU=$O(^TMP($J,0,XQU)) Q:XQU="" D PRTU G:XQUI MUS 54 D:XQMP MENUPAT G MUS 55 NEWPG ; 56 S X="" I XQPG,$E(IOST,1)="C" D CON S XQUI=(X="^") Q:XQUI 57 D HDR Q 58 CON ; 59 W !!,"Press return to continue or '^' to escape " R X:DTIME S:'$T X=U 60 Q 61 HDR ; 62 W @IOF S XQPG=XQPG+1 63 W "Page ",XQPG,?62,XQDT,!! S XQTAB=(76-$L(XQHDR))/2 W ?XQTAB,XQHDR 64 W !!,"USER NAME",?27,"LAST ON",?37,"PRIMARY MENU" W:XQMP ?63,"PATH(S)" 65 W !,$E(XQDSH,1,25),?27,$E(XQDSH,1,8),?37,$E(XQDSH,1,$S(XQMP:24,1:40)) W:XQMP ?63,$E(XQDSH,1,14) 66 Q 67 PRTU ; 68 I $Y>(IOSL-XQPA(0)-8) D:XQMP MENUPAT D NEWPG Q:XQUI 69 S J=$P(XQU,U,2),K="" S:$D(^VA(200,J,1.1)) K=$P(^(1.1),"^") S:$L(K) K=$E(K,4,5)_"/"_$E(K,6,7)_"/"_$E(K,2,3) W !,$E($P(XQU,U,1),1,27),?27,K 70 I $D(^VA(200,J,201)) S K=+^(201) I K>0,$D(^DIC(19,K,0)) W ?37,$E($P(^(0),U,1),1,24) 71 I XQMP D 72 .W ?63,"" 73 .S JJ=$O(^TMP($J,0,XQU,"A"),-1) 74 .F II=1:1:JJ W $G(^TMP($J,0,XQU,II)) I II'=JJ W "," 75 I 'XQMP D 76 .S II=0 F S II=$O(^TMP($J,0,XQU,II)) Q:II'>0 D 77 ..I ^TMP($J,0,XQU,II)["(S)" W " (Secondary menu)" S II="A" 78 Q 79 MENUPAT ; 80 W !!,$E(XQDSH,1,27)," MENU PATH(S) ",$E(XQDSH,1,29),! 81 F I=1:1:XQPA(0) S K=XQPA(0,I) W !,I,".",?4 F N=1:1 Q:'$L($P(K,",",N)) W:N>1 " ... " W $P(^DIC(19,$P(K,",",N),0),U,1) 82 I XQSCD W !,"(S) - secondary menu pathway" 83 Q 84 MUS G:X="^" OUT I XQPG,$E(IOST,1)="C" W !!,"Press return when finished viewing " R X:DTIME W @IOF G OUT 85 I $D(ZTSK) K ^%ZTSK(ZTSK) 86 OUT ; 87 D ^%ZISC 88 KILL K XQDT,XQGO,XQN,XQP,XQR,XQRV,XQOPT,XQPA,XQUI,XQSCD,XQDSH,XQU,N,K,J,X,XQA,XQD,XQHDR,XQK,XQP,XQPS,XQMP,XQPG,XX 89 K DIC,I,II,JJ,L,POP,Y I $D(ZTQUEUED),$D(ZTSK),ZTSK>0 K ^%ZTSK(ZTSK) 90 Q -
WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQ81.m
r613 r623 1 XQ81 ;SEA/AMF/LUKE,SF/RWF - Build menu trees ;12/10/07 2 ;;8.0;KERNEL;**81,116,157,253,478**;Jul 10, 1995;Build 3 3 BUILD ; 4 ; 5 RD2 N XQSTAT S XQSTAT=$$STATUS() 6 I 'XQSTAT W !!,"Some one else is rebuilding menus. Sorry." Q 7 K ZTSK 8 D MICRO ;Turn off micro surgery for now 9 ; 10 S XQSTART=$$HTE^XLFDT($H) 11 K XQFG W !!,"This option will build menu trees for each primary and secondary menu.",!,"You may build all the trees, or build them selectively, using 'verify'.",!,"Note that the 'compiled menus' will only be built into ^XUTL on this CPU.",! 12 S DIR(0)="Y",DIR("A")="Do you wish to verify each primary menu",DIR("B")="NO",DIR("??")="XQBUILDTREE-VER" D ^DIR K DIR G:$D(DIRUT) BLDEND1 S XQVE=(Y=1) 13 S DIR(0)="Y",DIR("A")="Would you like to build secondary menu trees too",DIR("B")="YES",DIR("??")="XQBUILDTREE-SEC" D ^DIR G:$D(DIRUT) BLDEND1 S XQBSEC=(Y=1) 14 ; 15 I 'XQVE S DIR(0)="Y",DIR("A")="Would you like to queue this job",DIR("B")="YES" D ^DIR K DIR G:$D(DIRUT) BLDEND1 I Y=1 D 16 .S ZTRTN="QUE^XQ81",ZTIO="" 17 .S ZTSAVE("XQVE")="",ZTSAVE("XQBSEC")="",ZTSAVE("XQSTART")="" 18 .S ZTDESC="Build menu trees in ^DIC(19,""AXQ"")" 19 .D ^%ZTLOAD 20 .I $D(ZTSK),'XQVE W !!,"Task #: ",ZTSK,! 21 .Q 22 ; 23 I $D(ZTSK) K ^DIC(19,"AXQ","P0") S XQALLDON="" G BLDEND 24 E S ^DIC(19,"AXQ","P0")=$H L +^DIC(19,"AXQ","P0") 25 ; 26 I 'XQVE S DIR(0)="Y",DIR("A")="Do you really wish to run this DIRECTLY (it may take some time)",DIR("B")="NO" D ^DIR K DIR G:$D(DIRUT) BLDEND1 G:Y'=1 RD2 27 ; 28 KIDS ;Entry from KIDS 29 I '$D(XQSTAT),$D(^DIC(19,"AXQ","P0")) S XQSTAT=$$STATUS I 'XQSTAT W !!," Some one else is building menus. Sorry." K XQSTAT Q 30 I '$D(^DIC(19,"AXQ","P0","STOP")) D MICRO 31 I '$D(^DIC(19,"AXQ","P0")) S ^DIC(19,"AXQ","P0")=$H L +^DIC(19,"AXQ","P0") 32 I '$D(XQVE) S XQFG=0,XQBSEC=1,XQVE=0 33 N XQNTREE,XQNDONE S (XQNTREE,XQNDONE)=0 34 ; 35 ;Set up the error trap so we can clear the screen if it blows 36 I $$NEWERR^%ZTER N $ETRAP,$ESTACK S $ETRAP="D ERR^XQ81" 37 E S X="ERR^XQ81",@^%ZOSF("TRAP") 38 ; 39 ;Set up the bar graph and window if not from KIDS 40 I '$D(XPDNM) D INIT^XPDID 41 I XPDIDVT D 42 .I $D(XPDIDTOT) S XQSAVTOT=XPDIDTOT 43 .S X="Rebuilding Menus" D TITLE^XPDID(X) 44 .S XPDIDTOT=50 ;Number of divisions in bar graph 45 .D UPDATE^XPDID(0) 46 .Q 47 ; 48 S XQSTART=$$HTE^XLFDT($H) 49 W !!,"Starting Menu Rebuild: ",XQSTART 50 S XQFG=0 W !!,"Collecting primary menus in the New Person file..." 51 ; 52 DQ ;Entry from taskman Write if $D(XQFG) 53 K ZTREQ 54 I '$D(XQSTART) S XQSTART=$$HTE^XLFDT($H) 55 N XQNOW,XQ8FLG,XQTASK 56 S XQ8FLG=0 57 S:'$D(XQNOW) XQNOW=$H 58 S ^DIC(19,"AXQ","P0")=XQNOW 59 S ^DIC(19,"AXQ","P0","STOP")=XQNOW ;Stop micro surgery if it's running 60 ; 61 S XQSEC=1,XQ81T="" I 'XQVE H 1 62 S XQI="" F XQK=0:0 S XQI=$O(^TMP("XQO",$J,XQI)) Q:XQI'=+XQI!(XQI="") I $D(^TMP("XQO",$J,XQI,0))#2 S $P(^(0),U,2)="" 63 S XQI="U" F XQK=0:0 S XQI=$O(^TMP("XQO",$J,XQI)) Q:"U"'[$E(XQI)!(XQI="") I $D(^TMP("XQO",$J,XQI,0))#2 S $P(^(0),U,2)="" 64 S XQI="P" F XQK=0:0 S XQI=$O(^TMP("XQO",$J,XQI)) Q:"P"'[$E(XQI)!(XQI="") I $D(^TMP("XQO",$J,XQI,0))#2,$L(^(0)) S XQ81T=^(0) Q 65 S:XQ81T="" XQ81T="Unknown" 66 S XQI="P" F XQK=0:0 S XQI=$O(^TMP("XQO",$J,XQI)) Q:"P"'[$E(XQI)!(XQI="") I "P"[$E(XQI),XQI'="P0" K ^TMP("XQO",$J,XQI) 67 ; 68 ;Find the various trees and put them into ^TMP($J), and count them 69 S:'$D(XQH) XQH=$H K ^TMP($J) S XQI=.5 F XQK=0:0 S XQI=$O(^VA(200,XQI)) Q:XQI'=+XQI I $D(^VA(200,XQI,0)),$L($P(^VA(200,XQI,0),U,3)) D SET 70 ; 71 S (XQNTREE,%)=0 F S %=$O(^TMP($J,%)) Q:%="" S XQNTREE=XQNTREE+1 72 S %=0 F S %=$O(^TMP($J,"SEC",%)) Q:%="" S XQNTREE=XQNTREE+1 73 ; 74 W:$D(XQFG) !!?20,"Primary menus found in the New Person file",!?20,"------------------------------------------" 75 W:$D(XQFG) !!,"OPTION NAME MENU TEXT",?49,"# OF",?62,"LAST",?71,"LAST",!?49,"USERS",?62,"USED",?71,"BUILT",! 76 S X="" F XQBLD=0:0 S XQBLD=$O(^TMP($J,XQBLD)) Q:XQBLD'>0!(X=U) I $D(^DIC(19,XQBLD,0)) S XQJ=^DIC(19,XQBLD,0) D VER 77 S XQSEC=0 I $D(XQFG),XQBSEC W !!,"Building secondary menu trees...." 78 I XQBSEC S X="" F XQBLD=0:0 S XQBLD=$O(^TMP($J,"SEC",XQBLD)) Q:XQBLD'>0 D SEC 79 I 'XQVE S XQK="P" F XQBLD=0:0 S XQK=$O(^TMP("XQO",$J,XQK)) Q:XQK'["P" S ^(XQK,0)=XQH 80 G BLDEND 81 ; 82 SEC S XQL="P"_XQBLD Q:$D(^TMP("XQO",$J,XQL)) D RD3 Q 83 S XQL="P" F XQN=0:0 S XQL=$O(^TMP("XQO",$J,XQL)) Q:$E(XQL)'="P" I $D(^TMP("XQO",$J,XQL,"^",XQBLD)) Q 84 D:$E(XQL)'="P" RD3 85 Q 86 ; 87 VER I $D(XQFG) D 88 .N XQMT,XQOPNM 89 .S XQK=$P(^TMP($J,XQBLD),U,2) 90 .S:$L(XQK) XQK=$E(XQK,4,5)_"/"_$E(XQK,6,7)_"/"_$E(XQK,2,3) 91 .S XQOPNM=$P(XQJ,U) 92 .S XQMT=$P(XQJ,U,2) I $L(XQMT)>28 S XQMT=$E(XQMT,1,25)_"..." 93 .W !,$P(XQJ,U,1) 94 .W:($L(XQOPNM)>20) ! 95 .W ?20,XQMT,?49,+^TMP($J,XQBLD),?60,XQK 96 .Q 97 ; 98 I $D(XQFG) S:$D(^DIC(19,"AXQ","P"_XQBLD,0)) XQ81T=+^(0) I $L(XQ81T) S %H=XQ81T D YMD^%DTC S XQK=X W ?71,$E(XQK,4,5),"/",$E(XQK,6,7),"/",$E(XQK,2,3) 99 ; 100 RD3 ;Update counter an rebuild it if necessary 101 I $D(XQFG),XPDIDVT D 102 .N % 103 .S XQNDONE=XQNDONE+1 104 .S %=(XQNDONE/XQNTREE)*XPDIDTOT 105 .D UPDATE^XPDID(%) 106 .Q 107 ; 108 S XQDIC="P"_XQBLD D CHK^XQ8 I XQRE W:$D(XQFG) !,"SOMEONE ELSE IS CURRENTLY REBUILDING THIS MENU" Q 109 I XQVE,XQSEC S DIR(0)="Y",DIR("A")="Rebuild",DIR("B")="YES" D ^DIR Q:$D(DIRUT) W ! Q:Y'=1 110 S XQFG1=1 D PM2^XQ8 111 I $D(ZTQUEUED) S ZTREQ="@" 112 Q 113 ; 114 SET G:'$D(^VA(200,XQI,201)) SET1 S XQK=+^(201) Q:'$L(XQK) ;I $D(XQFG) W:'(XQI#10) "." 115 S XQR="" S:$D(^VA(200,XQI,1.1)) XQR=$P(^(1.1),".",1) S XQP=1_U_XQR 116 I $D(^TMP($J,XQK)) S XQP=^TMP($J,XQK) S XQP=XQP+1_U_$S(XQR>$P(XQP,U,2):XQR,1:$P(XQP,U,2)) 117 I $D(^DIC(19,XQK,0)),$P(^(0),U,4)="M" S ^TMP($J,XQK)=XQP 118 ; 119 SET1 I XQBSEC F XQN=0:0 S XQN=$O(^VA(200,XQI,203,XQN)) Q:XQN'>0 S XQL=+^(XQN,0) I $D(^DIC(19,XQL,0)),$P(^(0),U,4)="M" S ^TMP($J,"SEC",XQL)="" 120 Q 121 ; 122 QUE ;Entry point for the option XQBUILDTREEQUE, and XQBUILDALL 123 ;Also called by CHEK^XQ83 124 S XQVE=0,XQBSEC=1 K XQFG 125 S XQSTART=$$HTE^XLFDT($H) 126 G DQ 127 ; 128 BLDEND ;File a report, cleanup, and quit. 129 ; 130 K %,%H,%TG,C,D,DIC,DIR,I,J,K,L,V,XQBSEC,X,Y,Z,XQL,XQN,XQRE,XQK,XQI,XQII,UU,XQH,XQPX,XQSAV,XQXUF,XQ81T,XQDATE,XQSEC,XQVE,XQBLD,XQP,XQR,XQJ 131 ; 132 I $D(XQALLDON) K XQALLDON Q ;Quit here if we're just creating a task 133 ; 134 D MERGET 135 D CLEAN 136 D MERGEX 137 ; 138 K ^TMP($J),^TMP("XQO",$J) 139 ; 140 ;Clear the flags and locks. 141 K ^XUTL("XQMERGED") ;Menues merged since last rebuild REACT^XQ84 142 K ^DIC(19,"AT") ;Micro message nodes 143 S ^XUTL("XQ","MICRO")=0 ;Number of Micro instances since last build 144 K ^DIC(19,"AXQ","P0","STOP") ;Allow Micro surgery to start up 145 K ^DIC(19,"AXQ","P0") ;Clear the rebuild flag (redundant, I know) 146 L -^DIC(19,"AXQ","P0") ;Unlock the rebuild flag, everybody's good to go 147 ; 148 S %=$S($D(XPDNM):"KIDS",$D(ZTSK):"QUEUED",1:"LIVE") 149 D REPORT^XQ84(%) 150 K XQSTART,ZTSK 151 ; 152 I '$D(XPDIDVT) K XQFG Q 153 ; 154 I $D(XQFG),XPDIDVT F %=((XQNDONE/XQNTREE)*XPDIDTOT):1:XPDIDTOT D UPDATE^XPDID(%) H .25 155 I $D(XQFG),XPDIDVT D UPDATE^XPDID(XPDIDTOT) 156 I $D(XQFG) W !!,"Menu Rebuild Complete: ",$$HTE^XLFDT($H) 157 ; 158 ; 159 H 2 160 ;If we're not from KIDS then clean it up, otherwise let kids do it. 161 I '$D(XPDNM) D 162 .D EXIT^XPDID() 163 .K XPDIDVT,XPDIDTOT 164 .Q 165 ; 166 I $D(XQSAVTOT) S XPDIDTOT=XQSAVTOT 167 K %,VALMCOFF,VALMCON,VALMIOXY,VALMSGR,VALMWD,XQFG,XQNDONE,XQNTREE,XQSAVTOT 168 Q 169 ; 170 ;================================Subroutines========================== 171 ; 172 MERGET ;Merge ^TMP("XQO",$J) into ^DIC(19,"AXQ") 173 N Q,X,XQFLAG,Y S X="P",XQFLAG=0,Q="""" 174 I $D(XQFG) W !!,"Merging...." 175 F S X=$O(^TMP("XQO",$J,X)) Q:X="" D 176 .L +^DIC(19,"AXQ",X):2 I '$T S XQFLAG=1 Q 177 .S %X="^TMP(""XQO"","_$J_","_Q_X_Q_"," 178 .S %Y="^DIC(19,""AXQ"","_Q_X_Q_"," 179 .K ^DIC(19,"AXQ",X) 180 .;M ^DIC(19,"AXQ",X)=^TMP("XQO",$J,X) 181 .D %XY^%RCR 182 .L -^DIC(19,"AXQ",X) 183 .K %X,%Y 184 .Q 185 ; 186 I XQFLAG,$D(XQFG) D 187 .N %,Y 188 .S Y=$P(X,"P",2) Q:Y="" 189 .S %=$G(^DIC(19,Y,0)) Q:%="" 190 .S Y=$P(%,"^",2) Q:%="" 191 .W !,?12,"Could not merge menu: "_Y 192 .Q 193 Q 194 ; 195 CLEAN ;Clean out unused menu trees from ^DIC(19,"AXQ") 196 N X,Y S X="P" 197 F S X=$O(^DIC(19,"AXQ",X)) Q:X="" D 198 .I X'="PXU" D 199 ..S Y=$E(X,2,99) 200 ..I '$D(^TMP($J,Y))&('$D(^TMP($J,"SEC",Y))) K ^DIC(19,"AXQ",X),^XUTL("XQO",X) 201 ..Q 202 .Q 203 Q 204 ; 205 MERGEX ;Merge ^DIC(19,"AXQ") into ^XUTL("XQO") 206 N Q,X,XQFLAG,Y S X="P",XQFLAG=0,Q="""" 207 F S X=$O(^DIC(19,"AXQ",X)) Q:X="" D 208 .L +^XUTL("XQO",X):2 I '$T S XQFLAG=1 Q 209 .S %X="^DIC(19,""AXQ"","_Q_X_Q_"," 210 .S %Y="^XUTL(""XQO"","_Q_X_Q_"," 211 .K ^XUTL("XQO",X) 212 .;M ^XUTL("XQO",X)=^DIC(19,"AXQ",X) 213 .D %XY^%RCR 214 .L -^XUTL("XQO",X) 215 .K %X,%Y 216 .Q 217 ; 218 I XQFLAG,$D(XQFG) D 219 .N %,Y 220 .S Y=$P(X,"P",2) Q:Y="" 221 .S %=$G(^DIC(19,Y,0)) Q:%="" 222 .S Y=$P(%,"^",2) Q:%="" 223 .W !,?12,"Could not merge menu: "_Y 224 .Q 225 ; 226 I 'XQFLAG,$D(XQFG) W " done." 227 Q 228 ; 229 STATUS() ;Are the menus being rebuilt even as we speak? 230 N %,XQTHEN 231 S %=$G(^DIC(19,"AXQ","P0")) I %="" Q 1 ;It finished. Never mind. 232 L +^DIC(19,"AXQ","P0"):0 ;If job is still running we can't lock it 233 I $T L -^DIC(19,"AXQ","P0") K ^("P0") Q 1 ;Job must have failed 234 Q 0 235 ; 236 ; 237 MICRO ;Turn off micro surgery 238 I $D(^DIC(19,"AXQ","P0","MICRO")) D 239 .S ^DIC(19,"AXQ","P0","STOP")=$H ;Turn off micro-surgery 240 .K ^DIC(19,"AXQ","P0","MICRO") 241 .H 2 242 .Q 243 Q 244 ; 245 ; 246 ERR ;Come here on error 247 N XQERROR 248 S XQERROR=$$EC^%ZOSV 249 D ^%ZTER 250 D EXIT^XPDID() 251 G UNWIND^%ZTER 252 Q 253 ; 254 BLDEND1 ;Quit and clean 255 K %,%H,%TG,C,D,DIC,DIR,I,J,K,L,V,XQBSEC,X,Y,Z,XQL,XQN,XQRE,XQK,XQI,XQII,UU,XQH,XQPX,XQSAV,XQXUF,XQ81T,XQDATE,XQSEC,XQVE,XQBLD,XQP,XQR,XQJ 256 Q 1 XQ81 ;SEA/AMF/LUKE,SF/RWF - Build menu trees ;03/03/2003 10:00 2 ;;8.0;KERNEL;**81,116,157,253**;Jul 10, 1995 3 BUILD ; 4 ; 5 RD2 N XQSTAT S XQSTAT=$$STATUS() 6 I 'XQSTAT W !!,"Some one else is rebuilding menus. Sorry." Q 7 K ZTSK 8 D MICRO ;Turn off micro surgery for now 9 ; 10 S XQSTART=$$HTE^XLFDT($H) 11 K XQFG W !!,"This option will build menu trees for each primary and secondary menu.",!,"You may build all the trees, or build them selectively, using 'verify'.",!,"Note that the 'compiled menus' will only be built into ^XUTL on this CPU.",! 12 S DIR(0)="Y",DIR("A")="Do you wish to verify each primary menu",DIR("B")="NO",DIR("??")="XQBUILDTREE-VER" D ^DIR K DIR G:$D(DIRUT) BLDEND S XQVE=(Y=1) 13 S DIR(0)="Y",DIR("A")="Would you like to build secondary menu trees too",DIR("B")="YES",DIR("??")="XQBUILDTREE-SEC" D ^DIR G:$D(DIRUT) BLDEND S XQBSEC=(Y=1) 14 ; 15 I 'XQVE S DIR(0)="Y",DIR("A")="Would you like to queue this job",DIR("B")="YES" D ^DIR K DIR G:$D(DIRUT) BLDEND I Y=1 D 16 .S ZTRTN="QUE^XQ81",ZTIO="" 17 .S ZTSAVE("XQVE")="",ZTSAVE("XQBSEC")="",ZTSAVE("XQSTART")="" 18 .S ZTDESC="Build menu trees in ^DIC(19,""AXQ"")" 19 .D ^%ZTLOAD 20 .I $D(ZTSK),'XQVE W !!,"Task #: ",ZTSK,! 21 .Q 22 ; 23 I $D(ZTSK) K ^DIC(19,"AXQ","P0") S XQALLDON="" G BLDEND 24 E S ^DIC(19,"AXQ","P0")=$H L +^DIC(19,"AXQ","P0") 25 ; 26 I 'XQVE S DIR(0)="Y",DIR("A")="Do you really wish to run this DIRECTLY (it may take some time)",DIR("B")="NO" D ^DIR K DIR G:$D(DIRUT) BLDEND G:Y'=1 RD2 27 ; 28 KIDS ;Entry from KIDS 29 I '$D(XQSTAT),$D(^DIC(19,"AXQ","P0")) S XQSTAT=$$STATUS I 'XQSTAT W !!," Some one else is building menus. Sorry." K XQSTAT Q 30 I '$D(^DIC(19,"AXQ","P0","STOP")) D MICRO 31 I '$D(^DIC(19,"AXQ","P0")) S ^DIC(19,"AXQ","P0")=$H L +^DIC(19,"AXQ","P0") 32 I '$D(XQVE) S XQFG=0,XQBSEC=1,XQVE=0 33 N XQNTREE,XQNDONE S (XQNTREE,XQNDONE)=0 34 ; 35 ;Set up the error trap so we can clear the screen if it blows 36 I $$NEWERR^%ZTER N $ETRAP,$ESTACK S $ETRAP="D ERR^XQ81" 37 E S X="ERR^XQ81",@^%ZOSF("TRAP") 38 ; 39 ;Set up the bar graph and window if not from KIDS 40 I '$D(XPDNM) D INIT^XPDID 41 I XPDIDVT D 42 .I $D(XPDIDTOT) S XQSAVTOT=XPDIDTOT 43 .S X="Rebuilding Menus" D TITLE^XPDID(X) 44 .S XPDIDTOT=50 ;Number of divisions in bar graph 45 .D UPDATE^XPDID(0) 46 .Q 47 ; 48 S XQSTART=$$HTE^XLFDT($H) 49 W !!,"Starting Menu Rebuild: ",XQSTART 50 S XQFG=0 W !!,"Collecting primary menus in the New Person file..." 51 ; 52 DQ ;Entry from taskman Write if $D(XQFG) 53 K ZTREQ 54 I '$D(XQSTART) S XQSTART=$$HTE^XLFDT($H) 55 N XQNOW,XQ8FLG,XQTASK 56 S XQ8FLG=0 57 S:'$D(XQNOW) XQNOW=$H 58 S ^DIC(19,"AXQ","P0")=XQNOW 59 S ^DIC(19,"AXQ","P0","STOP")=XQNOW ;Stop micro surgery if it's running 60 ; 61 S XQSEC=1,XQ81T="" I 'XQVE H 1 62 S XQI="" F XQK=0:0 S XQI=$O(^TMP("XQO",$J,XQI)) Q:XQI'=+XQI!(XQI="") I $D(^TMP("XQO",$J,XQI,0))#2 S $P(^(0),U,2)="" 63 S XQI="U" F XQK=0:0 S XQI=$O(^TMP("XQO",$J,XQI)) Q:"U"'[$E(XQI)!(XQI="") I $D(^TMP("XQO",$J,XQI,0))#2 S $P(^(0),U,2)="" 64 S XQI="P" F XQK=0:0 S XQI=$O(^TMP("XQO",$J,XQI)) Q:"P"'[$E(XQI)!(XQI="") I $D(^TMP("XQO",$J,XQI,0))#2,$L(^(0)) S XQ81T=^(0) Q 65 S:XQ81T="" XQ81T="Unknown" 66 S XQI="P" F XQK=0:0 S XQI=$O(^TMP("XQO",$J,XQI)) Q:"P"'[$E(XQI)!(XQI="") I "P"[$E(XQI),XQI'="P0" K ^TMP("XQO",$J,XQI) 67 ; 68 ;Find the various trees and put them into ^TMP($J), and count them 69 S:'$D(XQH) XQH=$H K ^TMP($J) S XQI=.5 F XQK=0:0 S XQI=$O(^VA(200,XQI)) Q:XQI'=+XQI I $D(^VA(200,XQI,0)),$L($P(^VA(200,XQI,0),U,3)) D SET 70 ; 71 S (XQNTREE,%)=0 F S %=$O(^TMP($J,%)) Q:%="" S XQNTREE=XQNTREE+1 72 S %=0 F S %=$O(^TMP($J,"SEC",%)) Q:%="" S XQNTREE=XQNTREE+1 73 ; 74 W:$D(XQFG) !!?20,"Primary menus found in the New Person file",!?20,"------------------------------------------" 75 W:$D(XQFG) !!,"OPTION NAME MENU TEXT",?49,"# OF",?62,"LAST",?71,"LAST",!?49,"USERS",?62,"USED",?71,"BUILT",! 76 S X="" F XQBLD=0:0 S XQBLD=$O(^TMP($J,XQBLD)) Q:XQBLD'>0!(X=U) I $D(^DIC(19,XQBLD,0)) S XQJ=^DIC(19,XQBLD,0) D VER 77 S XQSEC=0 I $D(XQFG),XQBSEC W !!,"Building secondary menu trees...." 78 I XQBSEC S X="" F XQBLD=0:0 S XQBLD=$O(^TMP($J,"SEC",XQBLD)) Q:XQBLD'>0 D SEC 79 I 'XQVE S XQK="P" F XQBLD=0:0 S XQK=$O(^TMP("XQO",$J,XQK)) Q:XQK'["P" S ^(XQK,0)=XQH 80 G BLDEND 81 ; 82 SEC S XQL="P"_XQBLD Q:$D(^TMP("XQO",$J,XQL)) D RD3 Q 83 S XQL="P" F XQN=0:0 S XQL=$O(^TMP("XQO",$J,XQL)) Q:$E(XQL)'="P" I $D(^TMP("XQO",$J,XQL,"^",XQBLD)) Q 84 D:$E(XQL)'="P" RD3 85 Q 86 ; 87 VER I $D(XQFG) D 88 .N XQMT,XQOPNM 89 .S XQK=$P(^TMP($J,XQBLD),U,2) 90 .S:$L(XQK) XQK=$E(XQK,4,5)_"/"_$E(XQK,6,7)_"/"_$E(XQK,2,3) 91 .S XQOPNM=$P(XQJ,U) 92 .S XQMT=$P(XQJ,U,2) I $L(XQMT)>28 S XQMT=$E(XQMT,1,25)_"..." 93 .W !,$P(XQJ,U,1) 94 .W:($L(XQOPNM)>20) ! 95 .W ?20,XQMT,?49,+^TMP($J,XQBLD),?60,XQK 96 .Q 97 ; 98 I $D(XQFG) S:$D(^DIC(19,"AXQ","P"_XQBLD,0)) XQ81T=+^(0) I $L(XQ81T) S %H=XQ81T D YMD^%DTC S XQK=X W ?71,$E(XQK,4,5),"/",$E(XQK,6,7),"/",$E(XQK,2,3) 99 ; 100 RD3 ;Update counter an rebuild it if necessary 101 I $D(XQFG),XPDIDVT D 102 .N % 103 .S XQNDONE=XQNDONE+1 104 .S %=(XQNDONE/XQNTREE)*XPDIDTOT 105 .D UPDATE^XPDID(%) 106 .Q 107 ; 108 S XQDIC="P"_XQBLD D CHK^XQ8 I XQRE W:$D(XQFG) !,"SOMEONE ELSE IS CURRENTLY REBUILDING THIS MENU" Q 109 I XQVE,XQSEC S DIR(0)="Y",DIR("A")="Rebuild",DIR("B")="YES" D ^DIR Q:$D(DIRUT) W ! Q:Y'=1 110 S XQFG1=1 D PM2^XQ8 111 I $D(ZTQUEUED) S ZTREQ="@" 112 Q 113 ; 114 SET G:'$D(^VA(200,XQI,201)) SET1 S XQK=+^(201) Q:'$L(XQK) ;I $D(XQFG) W:'(XQI#10) "." 115 S XQR="" S:$D(^VA(200,XQI,1.1)) XQR=$P(^(1.1),".",1) S XQP=1_U_XQR 116 I $D(^TMP($J,XQK)) S XQP=^TMP($J,XQK) S XQP=XQP+1_U_$S(XQR>$P(XQP,U,2):XQR,1:$P(XQP,U,2)) 117 I $D(^DIC(19,XQK,0)),$P(^(0),U,4)="M" S ^TMP($J,XQK)=XQP 118 ; 119 SET1 I XQBSEC F XQN=0:0 S XQN=$O(^VA(200,XQI,203,XQN)) Q:XQN'>0 S XQL=+^(XQN,0) I $D(^DIC(19,XQL,0)),$P(^(0),U,4)="M" S ^TMP($J,"SEC",XQL)="" 120 Q 121 ; 122 QUE ;Entry point for the option XQBUILDTREEQUE, and XQBUILDALL 123 ;Also called by CHEK^XQ83 124 S XQVE=0,XQBSEC=1 K XQFG 125 S XQSTART=$$HTE^XLFDT($H) 126 G DQ 127 ; 128 BLDEND ;File a report, cleanup, and quit. 129 ; 130 K %,%H,%TG,C,D,DIC,DIR,I,J,K,L,V,XQBSEC,X,Y,Z,XQL,XQN,XQRE,XQK,XQI,XQII,UU,XQH,XQPX,XQSAV,XQXUF,XQ81T,XQDATE,XQSEC,XQVE,XQBLD,XQP,XQR,XQJ 131 ; 132 I $D(XQALLDON) K XQALLDON Q ;Quit here if we're just creating a task 133 ; 134 D MERGET 135 D CLEAN 136 D MERGEX 137 ; 138 K ^TMP($J),^TMP("XQO",$J) 139 ; 140 ;Clear the flags and locks. 141 K ^XUTL("XQMERGED") ;Menues merged since last rebuild REACT^XQ84 142 K ^DIC(19,"AT") ;Micro message nodes 143 S ^XUTL("XQ","MICRO")=0 ;Number of Micro instances since last build 144 K ^DIC(19,"AXQ","P0","STOP") ;Allow Micro surgery to start up 145 K ^DIC(19,"AXQ","P0") ;Clear the rebuild flag (redundant, I know) 146 L -^DIC(19,"AXQ","P0") ;Unlock the rebuild flag, everybody's good to go 147 ; 148 S %=$S($D(XPDNM):"KIDS",$D(ZTSK):"QUEUED",1:"LIVE") 149 D REPORT^XQ84(%) 150 K XQSTART,ZTSK 151 ; 152 I '$D(XPDIDVT) K XQFG Q 153 ; 154 I $D(XQFG),XPDIDVT F %=((XQNDONE/XQNTREE)*XPDIDTOT):1:XPDIDTOT D UPDATE^XPDID(%) H .25 155 I $D(XQFG),XPDIDVT D UPDATE^XPDID(XPDIDTOT) 156 I $D(XQFG) W !!,"Menu Rebuild Complete: ",$$HTE^XLFDT($H) 157 ; 158 ; 159 H 2 160 ;If we're not from KIDS then clean it up, otherwise let kids do it. 161 I '$D(XPDNM) D 162 .D EXIT^XPDID() 163 .K XPDIDVT,XPDIDTOT 164 .Q 165 ; 166 I $D(XQSAVTOT) S XPDIDTOT=XQSAVTOT 167 K %,VALMCOFF,VALMCON,VALMIOXY,VALMSGR,VALMWD,XQFG,XQNDONE,XQNTREE,XQSAVTOT 168 Q 169 ; 170 ;================================Subroutines========================== 171 ; 172 MERGET ;Merge ^TMP("XQO",$J) into ^DIC(19,"AXQ") 173 N Q,X,XQFLAG,Y S X="P",XQFLAG=0,Q="""" 174 I $D(XQFG) W !!,"Merging...." 175 F S X=$O(^TMP("XQO",$J,X)) Q:X="" D 176 .L +^DIC(19,"AXQ",X):2 I '$T S XQFLAG=1 Q 177 .S %X="^TMP(""XQO"","_$J_","_Q_X_Q_"," 178 .S %Y="^DIC(19,""AXQ"","_Q_X_Q_"," 179 .K ^DIC(19,"AXQ",X) 180 .;M ^DIC(19,"AXQ",X)=^TMP("XQO",$J,X) 181 .D %XY^%RCR 182 .L -^DIC(19,"AXQ",X) 183 .K %X,%Y 184 .Q 185 ; 186 I XQFLAG,$D(XQFG) D 187 .N %,Y 188 .S Y=$P(X,"P",2) Q:Y="" 189 .S %=$G(^DIC(19,Y,0)) Q:%="" 190 .S Y=$P(%,"^",2) Q:%="" 191 .W !,?12,"Could not merge menu: "_Y 192 .Q 193 Q 194 ; 195 CLEAN ;Clean out unused menu trees from ^DIC(19,"AXQ") 196 N X,Y S X="P" 197 F S X=$O(^DIC(19,"AXQ",X)) Q:X="" D 198 .I X'="PXU" D 199 ..S Y=$E(X,2,99) 200 ..I '$D(^TMP($J,Y))&('$D(^TMP($J,"SEC",Y))) K ^DIC(19,"AXQ",X),^XUTL("XQO",X) 201 ..Q 202 .Q 203 Q 204 ; 205 MERGEX ;Merge ^DIC(19,"AXQ") into ^XUTL("XQO") 206 N Q,X,XQFLAG,Y S X="P",XQFLAG=0,Q="""" 207 F S X=$O(^DIC(19,"AXQ",X)) Q:X="" D 208 .L +^XUTL("XQO",X):2 I '$T S XQFLAG=1 Q 209 .S %X="^DIC(19,""AXQ"","_Q_X_Q_"," 210 .S %Y="^XUTL(""XQO"","_Q_X_Q_"," 211 .K ^XUTL("XQO",X) 212 .;M ^XUTL("XQO",X)=^DIC(19,"AXQ",X) 213 .D %XY^%RCR 214 .L -^XUTL("XQO",X) 215 .K %X,%Y 216 .Q 217 ; 218 I XQFLAG,$D(XQFG) D 219 .N %,Y 220 .S Y=$P(X,"P",2) Q:Y="" 221 .S %=$G(^DIC(19,Y,0)) Q:%="" 222 .S Y=$P(%,"^",2) Q:%="" 223 .W !,?12,"Could not merge menu: "_Y 224 .Q 225 ; 226 I 'XQFLAG,$D(XQFG) W " done." 227 Q 228 ; 229 STATUS() ;Are the menus being rebuilt even as we speak? 230 N %,XQTHEN 231 S %=$G(^DIC(19,"AXQ","P0")) I %="" Q 1 ;It finished. Never mind. 232 L +^DIC(19,"AXQ","P0"):0 ;If job is still running we can't lock it 233 I $T L -^DIC(19,"AXQ","P0") K ^("P0") Q 1 ;Job must have failed 234 Q 0 235 ; 236 ; 237 MICRO ;Turn off micro surgery 238 I $D(^DIC(19,"AXQ","P0","MICRO")) D 239 .S ^DIC(19,"AXQ","P0","STOP")=$H ;Turn off micro-surgery 240 .K ^DIC(19,"AXQ","P0","MICRO") 241 .H 2 242 .Q 243 Q 244 ; 245 ; 246 ERR ;Come here on error 247 N XQERROR 248 S XQERROR=$$EC^%ZOSV 249 D ^%ZTER 250 D EXIT^XPDID() 251 G UNWIND^%ZTER 252 Q -
WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALDATA.m
r613 r623 1 XQALDATA ;ISC-SF/JLI - PROVIDE DATA ON ALERTS ;4/9/07 13:39 2 ;;8.0;KERNEL;**207,285,443**;Jul 10, 1995;Build 4 3 Q 4 GETUSER(ROOT,XQAUSER,FRSTDATE,LASTDATE) ; 5 N XREF,XVAL,X,X2,X3,I,NCNT ; P443 6 S:$G(XQAUSER)'>0 XQAUSER=DUZ 7 S:$G(FRSTDATE)'>0 FRSTDATE=0 8 S:$G(LASTDATE)'>0 LASTDATE=0 9 S NCNT=0 K @ROOT 10 I FRSTDATE=0 D Q 11 . F I=0:0 S I=$O(^XTV(8992,XQAUSER,"XQA",I)) Q:I'>0 S X=^(I,0),X3=$G(^(3)),X2=$G(^(2)) D 12 . . S NCNT=NCNT+1 13 . . S @ROOT@(NCNT)=$S($P(X3,U)'="":"G ",$P(X,U,7,8)="^ ":"I ",1:" ")_$P(X,U,3)_U_$P(X,U,2)_$S($P(X2,U,3)'="":U_$P(X2,U,3),1:"") ; P443 14 . S @ROOT=NCNT 15 S XREF="R" 16 S XVAL=XQAUSER 17 D CHKTRAIL 18 Q 19 GETPAT(ROOT,PATIENT,FRSTDATE,LASTDATE) ; 20 N XREF,XVAL,NCNT 21 S NCNT=0 K @ROOT 22 I $G(PATIENT)'>0 S @ROOT=0 Q 23 S XREF="C" 24 S XVAL=PATIENT 25 D CHKTRAIL 26 Q 27 CHKTRAIL ; 28 N XQ1,X,X1,X2,X3 29 ; ZEXCEPT: FRSTDATE,LASTDATE,NCNT,ROOT,XREF,XVAL -- from GETPAT or GETUSER 30 F XQ1=0:0 S XQ1=$O(^XTV(8992.1,XREF,XVAL,XQ1)) Q:XQ1'>0 D 31 . S X=$G(^XTV(8992.1,XQ1,0)),X1=$G(^(1)),X3=$G(^(3)),X2=$G(^(2)) Q:X="" 32 . I FRSTDATE'>0,'$D(^XTV(8992,"AXQA",$P(X,U))) Q 33 . I FRSTDATE>0,$P(X,U,2)<FRSTDATE Q 34 . I FRSTDATE>0,LASTDATE>0,$P(X,U,2)>LASTDATE Q 35 . S NCNT=NCNT+1 36 . S @ROOT@(NCNT)=$S($P(X3,U)'="":"G ",$P(X1,U,2,3)="^":"I ",$P(X1,U,2,3)="":"I ",1:" ")_$P(X1,U)_U_$P(X,U)_$S($P(X2,U,3)'="":U_$P(X2,U,3),1:"") ; P443 37 S @ROOT=NCNT 38 Q 39 GETUSER1(ROOT,XQAUSER,FRSTDATE,LASTDATE) ; 40 N NCNT,KEY 41 S:$G(XQAUSER)'>0 XQAUSER=DUZ 42 S:$G(FRSTDATE)'>0 FRSTDATE=0 43 S:$G(LASTDATE)'>0 LASTDATE=0 44 S NCNT=0 K @ROOT 45 I FRSTDATE=0 D Q 46 . N X,X2,X3,X4,I S I="" F S I=$O(^XTV(8992,XQAUSER,"XQA",I),-1) Q:I'>0 S X=^(I,0),X2=$G(^(2)),X3=$G(^(3)),X4=$D(^(4)) D 47 . . I $P(X,U,4)'="" S $P(^XTV(8992,XQAUSER,"XQA",I,0),U,4)="" ; MARK SEEN 48 . . S NCNT=NCNT+1 49 . . S KEY=$S($P(X3,U)'="":"G ",X4>1:"L ",$P(X,U,7,8)="^ ":"I ",1:"R "),@ROOT@(NCNT)=KEY_$P(X,U,3)_U_$P(X,U,2) 50 . . I X2'="" D 51 . . . S NCNT=NCNT+1,@ROOT@(NCNT)=KEY_"-----Forwarded by: "_$$GET1^DIQ(200,($P(X2,U)_","),.01)_" Generated: "_$$DAT8^XQALERT($P(X2,U,2),1)_U_$P(X,U,2) 52 . . . I $P(X2,U,3)'="" S NCNT=NCNT+1,@ROOT@(NCNT)=KEY_"-----"_$P(X2,U,3)_U_$P(X,U,2) 53 . . . Q 54 . S @ROOT=NCNT 55 . Q 56 Q 1 XQALDATA ;ISC-SF/JLI - PROVIDE DATA ON ALERTS ;9/9/03 15:13 2 ;;8.0;KERNEL;**207,285**;Jul 10, 1995 3 Q 4 GETUSER(ROOT,XQAUSER,FRSTDATE,LASTDATE) ; 5 N XREF,XVAL 6 S:$G(XQAUSER)'>0 XQAUSER=DUZ 7 S:$G(FRSTDATE)'>0 FRSTDATE=0 8 S:$G(LASTDATE)'>0 LASTDATE=0 9 S NCNT=0 K @ROOT 10 I FRSTDATE=0 D Q 11 . F I=0:0 S I=$O(^XTV(8992,XQAUSER,"XQA",I)) Q:I'>0 S X=^(I,0),X3=$G(^(3)) D 12 . . S NCNT=NCNT+1 13 . . S @ROOT@(NCNT)=$S($P(X3,U)'="":"G ",$P(X,U,7,8)="^ ":"I ",1:" ")_$P(X,U,3)_U_$P(X,U,2) 14 . S @ROOT=NCNT 15 S XREF="R" 16 S XVAL=XQAUSER 17 D CHKTRAIL 18 Q 19 GETPAT(ROOT,PATIENT,FRSTDATE,LASTDATE) ; 20 N XREF,XVAL 21 S NCNT=0 K @ROOT 22 I $G(PATIENT)'>0 S @ROOT=0 Q 23 S XREF="C" 24 S XVAL=PATIENT 25 D CHKTRAIL 26 Q 27 CHKTRAIL ; 28 F XQ1=0:0 S XQ1=$O(^XTV(8992.1,XREF,XVAL,XQ1)) Q:XQ1'>0 D 29 . S X=$G(^XTV(8992.1,XQ1,0)),X1=$G(^(1)),X3=$G(^(3)) Q:X="" 30 . I FRSTDATE'>0,'$D(^XTV(8992,"AXQA",$P(X,U))) Q 31 . I FRSTDATE>0,$P(X,U,2)<FRSTDATE Q 32 . I FRSTDATE>0,LASTDATE>0,$P(X,U,2)>LASTDATE Q 33 . S NCNT=NCNT+1 34 . S @ROOT@(NCNT)=$S($P(X3,U)'="":"G ",$P(X1,U,2,3)="^":"I ",$P(X1,U,2,3)="":"I ",1:" ")_$P(X1,U)_U_$P(X,U) 35 S @ROOT=NCNT 36 Q 37 GETUSER1(ROOT,XQAUSER,FRSTDATE,LASTDATE) ; 38 N NCNT,KEY 39 S:$G(XQAUSER)'>0 XQAUSER=DUZ 40 S:$G(FRSTDATE)'>0 FRSTDATE=0 41 S:$G(LASTDATE)'>0 LASTDATE=0 42 S NCNT=0 K @ROOT 43 I FRSTDATE=0 D Q 44 . N X,X2,X3,X4,I S I="" F S I=$O(^XTV(8992,XQAUSER,"XQA",I),-1) Q:I'>0 S X=^(I,0),X2=$G(^(2)),X3=$G(^(3)),X4=$D(^(4)) D 45 . . I $P(X,U,4)'="" S $P(^XTV(8992,XQAUSER,"XQA",I,0),U,4)="" ; MARK SEEN 46 . . S NCNT=NCNT+1 47 . . S KEY=$S($P(X3,U)'="":"G ",X4>1:"L ",$P(X,U,7,8)="^ ":"I ",1:"R "),@ROOT@(NCNT)=KEY_$P(X,U,3)_U_$P(X,U,2) 48 . . I X2'="" D 49 . . . S NCNT=NCNT+1,@ROOT@(NCNT)=KEY_"-----Forwarded by: "_$$GET1^DIQ(200,($P(X2,U)_","),.01)_" Generated: "_$$DAT8^XQALERT($P(X2,U,2),1)_U_$P(X,U,2) 50 . . . I $P(X2,U,3)'="" S NCNT=NCNT+1,@ROOT@(NCNT)=KEY_"-----"_$P(X2,U,3)_U_$P(X,U,2) 51 . . . Q 52 . S @ROOT=NCNT 53 . Q 54 Q -
WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALDEL.m
r613 r623 1 XQALDEL ;ISC-SF.SEA/JLI - DELETE ALERTS ;4/9/07 15:132 ;;8.0;KERNEL;**6,24,65,114,174,285,443**;Jul 10, 1995;Build 4 3 4 5 6 DELETE 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 DELETEA 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 DELA 41 42 43 44 45 46 47 48 COUNT(%1,%2) 49 50 51 52 53 54 55 56 57 KILLOC 58 59 60 61 62 63 OLDDEL 64 65 66 67 68 69 70 71 72 73 OLDDEL1 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 OLDDEL2 98 99 100 101 102 103 104 KILLARCH 105 106 107 108 109 . S X1=$P($G(^XTV(8992.1,XQDEL1,0)),U,2),X2=$P($G(^(0)),U,8)110 111 112 113 114 115 USERDEL 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 GETBKUP(XQA,XQAUSER) 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 DIVENTIT(XQAUSER) 162 163 164 165 166 167 168 169 170 171 172 173 BKUPREVW 174 175 1 XQALDEL ;ISC-SF.SEA/JLI - DELETE ALERTS ;6/28/04 11:02 2 ;;8.0;KERNEL;**6,24,65,114,174,285**;Jul 10, 1995 3 ;; 4 Q 5 ; 6 DELETE ; 7 N XQAFOUND,XQADAT,XQX,XQK,XQXX,XQXY,XQJ,XQAID1 8 Q:'$D(XQAID) Q:XQAID="" S:'$D(XQAKILL) XQAKILL=0 S:$P(XQAID,";")="NO-ID" XQAKILL=1 9 S XQADAT=$$NOW^XLFDT() 10 I '$D(XQAUSER) N XQAUSER S XQAUSER=DUZ 11 S XQAFOUND=0 D 12 . S XQX=XQAUSER F XQK=0:0 S XQK=$O(^XTV(8992,XQAUSER,"XQA",XQK)) Q:XQK'>0 I $P(^(XQK,0),U,2)=XQAID S XQAFOUND=1 Q 13 S XQXX=$O(^XTV(8992.1,"B",XQAID,0)) I XQXX>0 S XQXY=$O(^XTV(8992.1,XQXX,20,"B",XQAUSER,0)) I XQXY>0,XQAFOUND,'$G(XQAUSERD) S $P(^XTV(8992.1,XQXX,20,XQXY,0),U,4)=XQADAT 14 K XQXX,XQXY 15 I '$D(^XTV(8992,"AXQA",XQAID,XQAUSER)) D KILLOC 16 F XQX=0:0 S XQX=$O(^XTV(8992,"AXQA",XQAID,XQX)) Q:XQX'>0 D Q:XQAKILL 17 . I XQAKILL S XQX=XQAUSER ; Make sure XQAKILL gets only XQAUSER 18 . F XQK=0:0 S XQK=$O(^XTV(8992,"AXQA",XQAID,XQX,XQK)) Q:XQK'>0 K ^(XQK),^XTV(8992,"AXQAN",$P(XQAID,";"),XQX,XQK) S XQAID1=XQAID D:$D(^XTV(8992,XQX,"XQA",XQK,0)) DELA S XQAID=XQAID1 19 K XQAID,XQX,XQJ,XQK,XQAID1,XQAKILL 20 Q 21 ; 22 DELETEA ; 23 N XQA1,XQADAT,XQAFOUND,XQX,XQXX,XQXY,XQK,XQJ 24 Q:'$D(XQAID) Q:XQAID="" S XQA1=$P(XQAID,";") 25 S XQADAT=$$NOW^XLFDT() 26 I '$D(XQAUSER) N XQAUSER S XQAUSER=DUZ 27 S:'$D(XQAKILL) XQAKILL=0 G:$P(XQAID,";")="NO-ID" DELETE 28 S XQAFOUND=0 D 29 . S XQX=XQAUSER F XQK=0:0 S XQK=$O(^XTV(8992,XQAUSER,"XQA",XQK)) Q:XQK'>0 I $P($G(^(XQK,0)),U,2)=XQAID S XQAFOUND=1 Q 30 S XQXX=$O(^XTV(8992.1,"B",XQAID,0)) I XQXX>0 S XQXY=$O(^XTV(8992.1,XQXX,20,"B",XQAUSER,0)) I XQXY>0,XQAFOUND,'$G(XQAUSERD) S $P(^XTV(8992.1,XQXX,20,XQXY,0),U,4)=XQADAT 31 I '$D(^XTV(8992,"AXQAN",XQA1,XQAUSER)) D KILLOC 32 I $P(XQAID,",",2)'=""!($P(XQAID,";",2)="") F XQX=0:0 S XQX=$O(^XTV(8992,"AXQAN",XQA1,XQX)) Q:XQX'>0 D Q:XQAKILL 33 . I XQAKILL S XQX=XQAUSER 34 . F XQK=0:0 S XQK=$O(^XTV(8992,"AXQAN",XQA1,XQX,XQK)) Q:XQK'>0 K ^(XQK) I $D(^XTV(8992,XQX,"XQA",XQK,0)) D DELA 35 I $P(XQAID,",",2)=""&($P(XQAID,";",2)'="") F XQX=0:0 S XQX=$O(^XTV(8992,"AXQA",XQAID,XQX)) Q:XQX'>0 D Q:XQAKILL 36 . I XQAKILL S XQX=XQAUSER 37 . S XQK=$O(^XTV(8992,"AXQA",XQAID,XQX,0)) Q:XQK'>0 K ^(XQK),^XTV(8992,"AXQAN",XQA1,XQX,XQK) I $D(^XTV(8992,XQX,"XQA",XQK,0)) D DELA 38 K XQAID,XQA1,XQX,XQK,XQAKILL 39 Q 40 DELA ; 41 N XQDEL11 S XQAID=$P($G(^XTV(8992,XQX,"XQA",XQK,0)),U,2),XQDEL11=$P($G(^(0)),U) K ^XTV(8992,XQX,"XQA",XQK) K:XQAID'="" ^XTV(8992,"AXQA",XQAID,XQX,XQK) 42 D COUNT(-1,XQX) 43 K:XQAID'="" ^XTV(8992,"AXQAN",$P(XQAID,";"),XQX,XQK) K:XQDEL11'="" ^XTV(8992,XQX,"XQA","B",XQDEL11,XQK) 44 S XQXX=$S(XQAID'="":$O(^XTV(8992.1,"B",XQAID,0)),1:0) I XQXX>0 S XQXY=$O(^XTV(8992.1,XQXX,20,"B",XQX,0)) I XQXY>0,$P(^XTV(8992.1,XQXX,20,XQXY,0),U,5)'>0 S $P(^(0),U,5)=XQADAT I $G(XQAUSERD) S $P(^(0),U,9)=DUZ 45 K XQXX,XQXY 46 Q 47 ; 48 COUNT(%1,%2) ;Change the count on the zero node, (amount, user) 49 Q:$G(%2)'>0 50 L +^XTV(8992,%2):10 51 I %1 S %=$P($G(^XTV(8992,%2,"XQA",0)),U,4)+%1 S:%'<0 $P(^(0),U,4)=% 52 I '%1 D 53 . N % S %1=0,%=0 F S %=$O(^XTV(8992,%2,"XQA",%)) Q:%'>0 S %1=%1+1 54 . S $P(^XTV(8992,%2,"XQA",0),U,4)=%1 55 L -^XTV(8992,%2) 56 Q 57 KILLOC ; 58 N XQX,XQK 59 S XQX=XQAUSER F XQK=0:0 S XQK=$O(^XTV(8992,XQAUSER,"XQA",XQK)) Q:XQK'>0 I $P(^(XQK,0),U,2)=XQAID D 60 . N XQAID D DELA 61 Q 62 ; 63 OLDDEL ; 64 N XQADAT,X2,XQDAT,XQDEL1 65 S XQADAT=$$NOW^XLFDT() 66 S X2=-15 I $G(ZTQPARAM)>0 S X2=-ZTQPARAM 67 S XQDAT=$$FMADD^XLFDT(DT,X2) 68 ;Loop thru users (XQDEL1) levels 69 F XQDEL1=0:0 S XQDEL1=$O(^XTV(8992,XQDEL1)) Q:XQDEL1'>0 D OLDDEL1 70 D KILLARCH 71 K X1,X2,X,XQDEL1,XQDEL2,XQDAT,XQA,XQADAT 72 Q 73 OLDDEL1 ;Loop thru the Alert (XQDEL2) level 74 L +^XTV(8992,XQDEL1):10 75 N XQAGLOB,KILLOLD,XQAZERO,XQAUSER,XQLIST,Y,XQAV,XQPRAMTY,XQDEL2,XQA 76 S XQAGLOB=$NA(^XTV(8992,XQDEL1,"XQA")),XQAUSER=XQDEL1 77 F XQDEL2=0:0 S XQDEL2=$O(@XQAGLOB@(XQDEL2)) Q:XQDEL2'>0 S XQAZERO=^(XQDEL2,0) D 78 . ; CHECK FOR BACKUP REVIEWER TO FORWARD ALERTS NEEDING ACTION -- P174 79 . I $P(XQAZERO,U,15)>0 I $$FMADD^XLFDT(+XQAZERO,+$P(XQAZERO,U,15))\1=DT D Q:$D(KILLOLD) ; changed '>DT to =DT so only send once without killing 80 . . N XQA D GETBKUP(.XQA,XQDEL1) 81 . . I $D(XQA) S XQALTYPE="BACKUP REVIEWER" D FORWARD^XQALFWD($P(XQAZERO,U,2),.XQA,"A","ALERT NOT PROCESSED BY "_$$GET1^DIQ(200,XQDEL1_",",.01)) S KILLOLD=1 82 . . Q ; End of Backup Reviewer Code -- P174 83 . I $P(XQAZERO,U,13)>0 I $$FMADD^XLFDT(+XQAZERO,+$P(XQAZERO,U,13))\1=DT D Q:$D(KILLOLD) ; P174 84 . . N XQA,I F I=0:0 S I=$O(^XMB(3.7,XQAUSER,9,I)) Q:I'>0 S XQAV=+^(I,0),XQA(XQAV)=XQAV 85 . . I $D(XQA) S XQALTYPE="EMAIL SURROGATE" D FORWARD^XQALFWD($P(XQAZERO,U,2),.XQA,"A","ALERT NOT PROCESSED BY "_$$GET1^DIQ(200,XQDEL1_",",.01)) S KILLOLD=1 86 . . Q 87 . I $P(XQAZERO,U,14)>0 I $$FMADD^XLFDT(+XQAZERO,+$P(XQAZERO,U,14))\1=DT D Q:$D(KILLOLD) ; P174 88 . . N XQA,I S I=$P($G(^VA(200,XQAUSER,5)),U) I I>0 S I=$P($G(^DIC(49,+I,0)),U,3) I I>0,$D(^VA(200,+I,0)) S XQA(+I)=+I 89 . . I $D(XQA) S XQALTYPE="CHIEF/SUPERVISOR" D FORWARD^XQALFWD($P(XQAZERO,U,2),.XQA,"A","ALERT NOT PROCESSED BY "_$$GET1^DIQ(200,XQDEL1_",",.01)) S KILLOLD=1 90 . . Q 91 . I XQDEL2'>XQDAT D OLDDEL2 92 . Q 93 K:$O(^XTV(8992,XQDEL1,"XQA",0))="" ^XTV(8992,XQDEL1,"XQA") 94 L -^XTV(8992,XQDEL1) 95 Q 96 ; 97 OLDDEL2 ; 98 N XQA,XQXX,XQXY 99 S XQA=$P(^XTV(8992,XQDEL1,"XQA",XQDEL2,0),U,2) K ^XTV(8992,XQDEL1,"XQA",XQDEL2) K:XQA'="" ^XTV(8992,"AXQA",XQA,XQDEL1),^XTV(8992,"AXQAN",$P(XQA,";"),XQDEL1) 100 D COUNT(-1,XQDEL1) 101 I XQA'="" S XQXX=$O(^XTV(8992.1,"B",XQA,0)) I XQXX>0 S XQXY=$O(^XTV(8992.1,XQXX,20,"B",XQDEL1,0)) I XQXY>0 S $P(^XTV(8992.1,XQXX,20,XQXY,0),U,6)=XQADAT 102 Q 103 ; 104 KILLARCH ; 105 ; Q ; turn off deletion from ALERT TRACKING file ; remove from XU*8*285 JLI 040624 106 N DA,DIK,XQDAT,XQDEL1,X1,X2,DA,DIK 107 S XQDAT=$$FMADD^XLFDT(DT,-30) 108 F XQDEL1=0:0 S XQDEL1=$O(^XTV(8992.1,XQDEL1)) Q:XQDEL1'>0 D 109 . S X1=$P(^XTV(8992.1,XQDEL1,0),U,2),X2=$P(^(0),U,8) 110 . S DA=XQDEL1 I X2="",X1>XQDAT Q 111 . I X2>0,DT<X2 Q 112 . S DIK="^XTV(8992.1," D ^DIK 113 Q 114 ; 115 USERDEL ; Delete undesired alerts for a user 116 N DA,DIC,XQAUSERD 117 S DIC("A")="Select NEW PERSON entry for deletion of alerts: " 118 S DIC(0)="AEQM",DIC=200 119 D ^DIC K DIC Q:Y'>0 S XQAUSER=+Y 120 S XQALDELE=1 121 K XQX1 122 D DOIT^XQALERT1 123 K XQALDELE S XQAUSERD=1 124 I $D(XQX1),XQX1>0 D 125 . F Q:XQX1="" S DA=+XQX1,XQX1=$P(XQX1,",",2,99) D I XQX1="" S Y=$O(XQX1(0)) I Y>0 S XQX1=XQX1(Y) K XQX1(Y) 126 . . S XQAID=$P(^TMP("XQ",$J,"XQA1",DA),U,2),XQAKILL=1 127 . . I XQAID="" K ^XTV(8992,XQAUSER,"XQA",+^TMP("XQ",$J,"XQA1",DA,1)) 128 . . I XQAID'="" D DELETE 129 . . K ^TMP("XQ",$J,"XQA1",DA),^TMP("XQ",$J,"XQA",(999999-DA)) 130 K XQAUSER,XQX1 131 Q 132 ; 133 GETBKUP(XQA,XQAUSER) ; JLI 030129 - REMOVED TO SEPARATE METHOD 134 N I,XQORY,XQENTITY,XQPARAM,XQERR,K,XQAV,XQLIST 135 S XQPARAM="XQAL BACKUP REVIEWER" 136 D GETLST^XPAR(.XQLIST,"USR.`"_XQAUSER,XQPARAM,"Q",.XQERR) S:$D(XQLIST)>1 XQPRAMTY=200 ; USER 137 I '($D(XQLIST)>1) S I=$$GET1^DIQ(200,XQAUSER_",",29,"I") I I>0 D GETLST^XPAR(.XQLIST,"SRV.`"_I,XQPARAM,"Q",.XQERR) S:$D(XQLIST)>1 XQPRAMTY=49 ; SERVICE 138 I '($D(XQLIST)>1) D GETLST^XPAR(.XQLIST,$$DIVENTIT(XQAUSER),XQPARAM,"Q",.XQERR) S:$D(XQLIST)>1 XQPRAMTY=4 ; DIVISION 139 I '($D(XQLIST)>1) D GETLST^XPAR(.XQLIST,"SYS",XQPARAM,"Q",.XQERR) S:$D(XQLIST)>1 XQPRAMTY=4.2 ; SYSTEM 140 F I=0:0 S I=$O(XQLIST(I)) Q:I'>0 S XQAV=$P(XQLIST(I),U,2),XQA(XQAV)=XQAV 141 ; Removed Teams per Curtis Anderson with CPRS 142 ;I '$D(XQA) D ; NONE UNDER USER - CHECK FOR ENTRIES IN PARAMETER FILE FOR TEAMS 143 ;. I $T(TEAMPR^ORQPTQ1)]"" D TEAMPR^ORQPTQ1(.XQORY,XQAUSER) K:+$G(XQORY(1))<1 XQORY ; GET TEAM ID'S IF ANY ; CONTROLLED SUBSCRIPTION 144 ;. S I=0 F S I=$O(XQORY(I)) Q:I'>0 K XQLIST D GETLST^XPAR(.XQLIST,$P(XQORY(I),U,2)_";OR(100.21,",XQPARAM,"Q",.ERR) I $D(XQTEAM) D 145 ;. . N K F K=0:0 S K=$O(XQLIST(K)) Q:K'>0 S XQAV=$P(XQLIST(K),U,2),XQA(XQAV)=XQAV 146 ;. . Q` 147 ;. Q 148 ;I '$D(XQLIST) D ; NO TEAM ENTRIES, CHECK OTHER ENTITIES (SERVICE,DIVISION,SYSTEM) 149 ;. S XQENTITY="SYS" 150 ;. S I=$$GET1^DIQ(200,XQAUSER_",",16,"I") I I>0 S XQENTITY="DIV.`"_I_U_XQENTITY ; DIVISION 151 ;. S I=$$GET1^DIQ(200,XQAUSER_",",29,"I") I I>0 S XQENTITY="SRV.`"_I_U_XQENTITY ; SERVICE\SECTION 152 ;. D GETLST^XPAR(.XQLIST,XQENTITY,XQPARAM,"Q",.XQERR) F I=0:0 S I=$O(XQLIST(I)) Q:I'>0 S XQAV=+$P(XQLIST(I),U,2),XQA(XQAV)=XQAV 153 ;. Q 154 ;I '$D(XQA) D ; NO PARAMETERS ENTERED - USE LAST RESORT MAIL GROUP 155 ;. S XQJ="G.XQAL UNPROCESSED ALERTS" D GROUP^XQALSET1 156 ;. I '$D(XQA) S XQJ="G.PATCH" D GROUP^XQALSET1 ; REALLY LAST RESORT 157 ;. F I=0:0 S I=$O(XQA(I)) Q:I'>0 S XQA(I)=I 158 ;. Q 159 Q 160 ; 161 DIVENTIT(XQAUSER) ; 162 N ENTITY,NCNT,DIVNAM,I 163 S ENTITY="" I DUZ=XQAUSER S ENTITY="DIV.`"_DUZ(2) 164 I ENTITY="" D 165 . K NCNT,DIVNAM S NCNT=0 F I=0:0 S I=$O(^VA(200,XQAUSER,2,I)) Q:I'>0 S NCNT=NCNT+1,DIVNAM(NCNT)=+^(I,0) I $P(^(0),U,2) S DIVNAM=+^(0) 166 . I NCNT'>0 Q 167 . I NCNT=1 S ENTITY="DIV.`"_DIVNAM(1) Q 168 . I $D(DIVNAM)#2 S ENTITY="DIV.`"_DIVNAM Q 169 . F I=1:1:NCNT S ENTITY="DIV.`"_DIVNAM(I)_$S(ENTITY'="":U,1:"")_ENTITY 170 I ENTITY="" S ENTITY="DIV.`"_$$GET1^DIQ(8989.3,"1,",217,"I") 171 Q ENTITY 172 ; 173 BKUPREVW ;OPT - SET BACKUP REVIEWER(S) IN PARAMETER FILE 174 G BKUPREVW^XQALBUTL 175 ; -
WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALERT1.m
r613 r623 1 XQALERT1 ;ISC-SF.SEA/JLI - ALERT HANDLER ;4/9/07 14:54 2 ;;8.0;KERNEL;**20,65,114,123,125,164,173,285,366,443**;Jul 10, 1995;Build 4 3 ;; 4 Q 5 ; 6 DOIT I $D(XQX1),XQX1'>0 K XQX1 7 I $D(XQAID) D I '$D(XQAID) G EXIT 8 . N XQACHOIC,REASK S REASK=0 9 . I '$D(XQX1),$O(^XTV(8992,XQAUSER,"XQA",+$O(^XTV(8992,XQAUSER,"XQA",0))))'>0,$G(XQAROUX)="^ " S XQAROU="" 10 AGAIN . S XQACHOIC="Y:YES;N:NO;C:CONTINUE;",XQAQ("?")="Enter Y (or C) to continue, N to exit alert processing" 11 . S XQACHOIC=$G(XQACHOIC)_"F:FORWARD ALERT;R:RENEW(MAKE NEW AGAIN);" S XQAQ("?",1)="Enter F to forward this alert to someone else",XQAQ("?",2)="Enter R to Renew (Make New) this alert" 12 . D I REASK=1 G AGAIN 13 . . S REASK=0 W !! K DIR S DIR(0)="SA^"_XQACHOIC,DIR("A")=$S(XQACHOIC["F:":"Continue (Y/N) or F(orward) or R(enew) ",1:"Continue Processing (Y/N) "),DIR("B")="YES" M DIR("?")=XQAQ("?") D ^DIR K DIR 14 . . I $D(DUOUT)!$D(DIRUT) S Y="N" K DUOUT,DIRUT 15 . . I Y="N" D:$D(XQAKILL) DELETEA^XQALERT K XQAID 16 . . I Y="R" S REASK=REASK+1 K XQAKILL I '$D(^XTV(8992,"AXQA",XQAID,DUZ)) D RESTORE 17 . . I Y="F" D:'$D(^XTV(8992,"AXQA",XQAID,DUZ)) RESTORE D FRWRDONE S REASK=REASK+1 18 . . Q 19 . Q 20 I $D(XQAKILL) D DELETEA^XQALERT 21 S XQAREV=1,XQXOUT=0,XQK=0,XQACNT=0 K XQADATA,XQAID,XQAROU,XQAKILL,XQAROUX 22 I '$D(XQX1) S XQX1=0 K ^TMP("XQ",$J,"XQA"),^("XQA1"),^("XQA2") I $O(^XTV(8992,XQAUSER,"XQA",0))'>0 K XQX1 D:'$G(^TMP("XQALERT1",$J,"NOTFIRST")) CHKSURO G:$O(^XTV(8992,XQAUSER,"XQA",0))'>0 EXIT S XQX1=0 ; P366 23 I $$ACTVSURO^XQALSURO(XQAUSER)'>0 D RETURN^XQALSUR1(XQAUSER) ; P366 24 S ^TMP("XQALERT1",$J,"NOTFIRST")=1 ; Added 2/2/99 jli to clear flag for initial entry 25 ;Sort and remove display only 26 I 'XQX1 W !!! D 27 . D SORT 28 ; Now display them. 29 SUBLOOP W @IOF 30 N XQZ1,XQZ 31 S XQK=0 F XQI=0:0 Q:XQX1!XQXOUT S XQI=$O(^TMP("XQ",$J,"XQA",XQI)) Q:XQI'>0 S XQX=^(XQI),XQII=^(XQI,1),XQZ=^(2),XQZ1=^(3),XQZ4=^(4) D I XQX'="" D DOIT1 32 . I '$D(^XTV(8992,XQAUSER,"XQA",XQII)) S XQX="" K ^TMP("XQ",$J,"XQA",XQI),^TMP("XQ",$J,"XQA1",(999999-XQI)) 33 . Q 34 S:'$D(XQXOUT) XQXOUT=0 G:XQXOUT EXIT G:XQK'>0&'XQX1 EXIT I 'XQX1 D ASK G:XQXOUT EXIT 35 G:+XQX1=0 EXIT I XQX1<0 S XQX1=0 G DOIT 36 I $D(XQALDELE)!$D(XQALFWD) Q 37 ;D WAIT(+XQX1) G:XQXOUT EXIT 38 G:XQXOUT EXIT 39 G EN^XQALDOIT 40 ; 41 RESTORE ; Restore a deleted message for use 42 N ALERTREF,XTVGLOB,ADUZ,X,X0,X1,X2,TIME,MESG,OPT,TAG,ROU,X4,LONG 43 S XTVGLOB=$NA(^XTV(8992,DUZ,"XQA")) 44 S ADUZ=$O(^XTV(8992,"AXQA",XQAID,0)) I ADUZ>0 S TIME=$O(^(ADUZ,0)) D I 1 45 . M @XTVGLOB@(TIME)=^XTV(8992,ADUZ,"XQA",TIME) K @XTVGLOB@(TIME,2) ; copy alert, kill comment if any 46 E S ALERTREF=$O(^XTV(8992.1,"B",XQAID,0)) Q:ALERTREF'>0 D ; otherwise rebuild from alert tracking file if possible 47 . S X0=^XTV(8992.1,ALERTREF,0),X1=$G(^(1)),X2=$G(^(2)),X4=$O(^(4,0)) 48 . S TIME=$P($P(X0,U),";",3),MESG=$P(X1,U),OPT=$P(X1,U,2),TAG=$P(X1,U,3),ROU=$P(X1,U,4),LONG=(X4>0) 49 . S X=TIME_U_XQAID_U_MESG_U_U_$S(OPT'=""!(ROU'=""):"R",LONG:"L",1:"I")_U_U_$S(OPT'="":OPT,TAG'="":TAG,1:"")_U_$S(OPT'="":"",ROU'="":ROU,1:" ") 50 . S @XTVGLOB@(TIME,0)=X I $G(X2)'="" S ^(1)=X2 51 S ^XTV(8992,"AXQA",XQAID,DUZ,TIME)="",^XTV(8992,"AXQAN",$E($P(XQAID,";"),1,30),DUZ,TIME)="" 52 Q 53 ; 54 EXIT ; 55 I $G(XQALAST)="I",$G(DUZ("AUTO")) D WAIT2 56 I $D(XQALDELE)!$D(XQALFWD) Q 57 K ^TMP("XQ",$J,"XQA"),^("XQA1"),^("XQA2"),XQI,XQX,XQJ,XQK,XQX1,XQX2,XQXOUT,XQ1,XQII,XQACNT,XQA1,XQAREV,%ZIS,XQAROU,XQALAST,XQAROUX,XQON,XQOFF,XQ1ON,XQ1OFF,XQOUT,XQAQ 58 K ^TMP("XQALERT1",$J) 59 Q 60 ; 61 ; CHKSURO added 2/2/99 to give user opportunity to add/remove surrogate if no alerts present 62 CHKSURO ; If user selects process alerts with no alerts present, give him/her the opportunity to add or delete a surrogate 63 ; P366 - list currently established surrogates if any 64 I '$G(^TMP("XQALERT1",$J,"NOTFIRST")) W !!,"You have no alerts for processing.",! 65 D SURROGAT^XQALSURO ; XU*8*17 66 Q 67 ; 68 DOIT1 ; 69 I XQK=0 S XQALINFO=0 I '$D(XQALFWD) W @IOF 70 S XQON="$C(0)",XQOFF="$C(0)" S XQOUT=$P(XQX,U,3) I ($$UP^XLFSTR(XQOUT)["CRITICAL")!($$UP^XLFSTR(XQOUT)["ABNORMAL IMA") D:'$D(XQ1ON) SETREV^XQALERT S XQON=XQ1ON,XQOFF=XQ1OFF ; P285 71 S XQK=XQK+1 W !,$J(XQK,2),".",$S(XQZ4:"L",$P(XQX,U,8)=" ":"I",1:" ")," ",@XQON,$E($P(XQX,U,3),1,70),@XQOFF S:$P(XQX,U,8)=" " XQALINFO=XQALINFO+1 D:XQZ1'="" ; P285 72 . W !?8,"Forwarded by: ",$P(^VA(200,+XQZ1,0),U)," Generated: ",$$DAT8^XQALERT(+$P($P(XQX,U,2),";",3),1) 73 . I $P(XQZ1,U,3)'="" W !?8,$P(XQZ1,U,3) 74 S ^TMP("XQ",$J,"XQA1",XQK)=XQX,^(XQK,1)=XQII,^(2)=XQZ,^(3)=XQZ1 75 I ($Y+6)>IOSL N XQKVALUE S XQKVALUE=XQK D ASK0(XQI) S:'$D(XQK) XQK=XQKVALUE Q:XQX1!(XQXOUT) W @IOF 76 Q 77 ; 78 ASK0(XQI) ;Stack XQI 79 ASK ; 80 N XQALNEWF K XQALAST 81 ;I '$D(XQALDELE)&'$D(XQALFWD) S XQALNEWF=$P(^XTV(8992,XQAUSER,0),U,5) I XQALNEWF<20 D 82 ;. N XQALFDA 83 ;. S XQALNEWF=XQALNEWF+1,XQALFDA=(8992,(XQAUSER_","),.05)=XQALNEWF D FILE^DIE("","XQALFDA") 84 ;. W !,"NEW OPTIONS: S-to add/remove SURROGATE and D-to selectively Delete SOME alerts" 85 S XQ1=0,XQXOUT=0 W !?10,"Select from 1 to ",XQK W:$D(XQALDELE) " to DELETE" W:$D(XQALFWD) " to FORWARD" 86 W !?10,"or enter ?, A, " W:'$D(XQALDELE)&'$D(XQALFWD)&(XQALINFO>0) "I, D, " W:'$D(XQALDELE)&'$D(XQALFWD) "F, S, P, M, R, " W "or ^ to exit" I XQI>0,$O(^XTV(8992,XQAUSER,"XQA",XQI))>0 W !?10,"or RETURN to continue" S XQ1=1 87 R ": ",XQII:DTIME S:'$T!(XQII[U)!(XQII=""&'XQ1) XQXOUT=1 Q:XQXOUT 88 I '$D(XQALDELE)&'$D(XQALFWD),"PpMm"[$E(XQII_".") D MORP^XQALDOIT D:"Pp"[$E(XQII_".") PRINT^XQALDOIT D:"Mm"[$E(XQII_".") MAIL^XQALDOIT K ^TMP("XQ",$J,"XQA2") G ASK 89 I XQII'="",XQII["?" D HELP G ASK 90 I XQII=""&XQ1 Q 91 I "IiAaFfRrSsDd"'[$E(XQII_"."),$L(XQII)>31,$E(XQII,1,32)?1N.N W !,$C(7)," ?? Invalid number entered",! G ASK 92 I "IiAaFfRrSsDd"'[$E(XQII_"."),(XQII<1)!(XQII>XQK) W $C(7)," ??",! G ASK 93 I '$D(XQALDELE)&'$D(XQALFWD),"Ff"[$E(XQII) D FWRD^XQALFWD S XQX1=-2 Q ; MODIFIED 7-6 94 I '$D(XQALDELE)&'$D(XQALFWD),"Ss"[$E(XQII) D CHKSURO S XQX1=-1 Q 95 I '$D(XQALDELE)&'$D(XQALFWD),"Dd"[$E(XQII) D ASKDEL S XQX1=-2 Q ; MODIFIED 7-6 96 I '$D(XQALDELE),"Rr"[$E(XQII) S XQX1=-2 Q 97 I "Aa"[$E(XQII) S X="1-"_XQACNT,DIR(0)="LV^1:"_XQACNT D ^DIR K DIR,XQX1 M XQX1=Y S XQII="" K Y ;Merge list from Y 98 I XQII'="","Ii"[$E(XQII) S XQX1(0)="",XQX2=0,XQII="" F XQK=0:0 S XQK=$O(^TMP("XQ",$J,"XQA1",XQK)) S:XQK'>0 XQX1=XQX1(0) Q:XQK'>0 I $P(^(XQK),U,7,8)="^ " S XQX1(XQX2)=XQX1(XQX2)_XQK_"," S:$L(XQX1(XQX2))>240 XQX2=XQX2+1,XQX1(XQX2)="" 99 I XQII="" Q 100 S X=XQII,DIR(0)="LV^1:"_XQK D ^DIR I '$D(Y) W $C(7)," ??" D HELP G ASK ;Use of 'LV' is special 101 K XQX1 M XQX1=Y K Y S Y=XQX1 ;Merge list from Y 102 Q 103 WAIT(IFN) ;Wait for user input if last alert is INFO and next isn't. 104 N X,YY Q:$G(XQXOUT) 105 S X=$G(^TMP("XQ",$J,"XQA1",IFN)),YY=$P(X,U,7,8),YY=$S(YY="^ ":"I",YY="^":"O",1:"R") 106 I $G(XQALAST)="I","OR"[YY D WAIT2 107 I YY="I",$Y+4>IOSL D WAIT2 W @IOF 108 S XQALAST=YY 109 Q 110 WAIT2 ;Wait for user input before continuing 111 N DIR,Y,DIROUT,DIRUT S DIR(0)="E",DIR("?")="The next ALERT may cause the loss of info on the screen." 112 D ^DIR S:$D(DIRUT) XQXOUT=1 113 Q 114 ; 115 HELP W !!,"YOU MAY ENTER:",!?3,$S(XQK>1:"One or more numbers",1:"A number")," in the range 1 to ",XQK," to select specific alert(s)" 116 W !?6,"for "_$S($D(XQALDELE):"DELETION.",$D(XQALFWD):"FORWARDING",1:"processing.") W:XQK>1 " This may be a series of numbers, e.g., 2,3,6-9" 117 W !?3,"A to "_$S($D(XQALDELE):"DELETE",$D(XQALFWD):"FORWARD",1:"process")," all of the pending alerts in the order shown." 118 W:'$D(XQALDELE)&'$D(XQALFWD) !?3,"I to process all of the INFORMATION ONLY alerts, if any, without further ado." 119 W:'$D(XQALDELE)&'$D(XQALFWD) !?3,"S to add or remove a surrogate to receive alerts for you" 120 W:'$D(XQALDELE)&'$D(XQALFWD) !?3,"F to forward one or more specific alerts. Forwarding may be as an ALERT",!,"to specific user(s) and/or mail group(s), or as a MAIL MESSAGE, or to a",!,"specific PRINTER." 121 W:'$D(XQALDELE)&'$D(XQALFWD) !?3,"D to delete specific alerts (some alerts may not be deleted)" 122 W:'$D(XQALDELE)&'$D(XQALFWD) !?3,"P to print a copy of the pending alerts on a printer" 123 W:'$D(XQALDELE)&'$D(XQALFWD) !?3,"M to receive a MailMan message containing a copy of these pending alerts" 124 W:'$D(XQALDELE) !?3,"R to Redisplay the available alerts" 125 W !?3,"^ to exit" 126 I XQI W !?5,"or RETURN to see additional pending ALERTS" 127 W !! 128 Q 129 ; 130 SORT ;Sort and remove display only 131 N XQZ,XQZ1,XQZ4,XQI,XQK,XQX,XQJ 132 F XQI=0:0 S XQI=$O(^XTV(8992,XQAUSER,"XQA",XQI)) Q:XQI'>0 S XQX=^(XQI,0),XQZ=$G(^(1)),XQZ1=$G(^(2)),XQZ4=$O(^(4,0)) S XQJ=$P(XQX,U,7,8) K:XQJ=U ^XTV(8992,XQAUSER,"XQA",XQI) I XQJ'=U D 133 . S XQACNT=XQACNT+1,XQJ=$S(XQAREV:999999-XQACNT,1:XQACNT),^TMP("XQ",$J,"XQA",XQJ)=XQX,^(XQJ,1)=XQI,^(2)=XQZ,^(3)=XQZ1,^(4)=XQZ4 134 S XQK=0 F XQI=0:0 S XQI=$O(^TMP("XQ",$J,"XQA",XQI)) Q:XQI'>0 S XQK=XQK+1 M ^TMP("XQ",$J,"XQA1",XQK)=^TMP("XQ",$J,"XQA",XQI) 135 Q 136 ; 137 ASKDEL ; 138 N XQALDELE,XQX1COPY,XQAID,DA,XQAKILL,XQXOUT,XQAUSERD,XQALVALU 139 S XQALDELE=1 140 K XQX1 141 D DOIT^XQALERT1 142 K XQALDELE S XQAUSERD=1 143 I $D(XQX1),XQX1>0 D 144 . M XQX1COPY=XQX1 145 . F Q:XQX1="" S DA=+XQX1,XQX1=$P(XQX1,",",2,99) D I XQX1="" S Y=$O(XQX1(0)) I Y>0 S XQX1=XQX1(Y) K XQX1(Y) 146 . . S XQAID=$P(^TMP("XQ",$J,"XQA1",DA),U,2),XQALVALU=^(DA),XQAKILL=1 147 . . I $P(XQALVALU,U,8)=" "!$P(XQALVALU,U,10) D 148 . . . I XQAID="" K ^XTV(8992,XQAUSER,"XQA",+^TMP("XQ",$J,"XQA1",DA,1)) 149 . . . I XQAID'="" D DELETE^XQALDEL 150 . . . K ^TMP("XQ",$J,"XQA1",DA),^TMP("XQ",$J,"XQA",(999999-DA)) 151 . K XQX1 M XQX1=XQX1COPY S XQAID=0 152 . F Q:XQX1="" S DA=+XQX1,XQX1=$P(XQX1,",",2,99) D I XQX1="" S Y=$O(XQX1(0)) I Y>0 S XQX1=XQX1(Y) K XQX1(Y) 153 . . I $D(^TMP("XQ",$J,"XQA1",DA)) W:'XQAID !!,"Unable to delete alerts which require action: ",DA W:XQAID ",",DA S XQAID=1 154 . I XQAID=1 K DIR S DIR(0)="E" D ^DIR K DIR 155 K XQX1,XQAKILL 156 Q 157 ; 158 FRWRDONE ; 159 N XQX1,XQALFWDL S XQALFWDL(1)=XQAID 160 N XQAID 161 D FWDONE^XQALFWD 162 Q 1 XQALERT1 ;ISC-SF.SEA/JLI - ALERT HANDLER ;9/6/05 15:13 2 ;;8.0;KERNEL;**20,65,114,123,125,164,173,285,366**;Jul 10, 1995 3 ;; 4 Q 5 ; 6 DOIT I $D(XQX1),XQX1'>0 K XQX1 7 I $D(XQAID) D I '$D(XQAID) G EXIT 8 . N XQACHOIC,REASK S REASK=0 9 . I '$D(XQX1),$O(^XTV(8992,XQAUSER,"XQA",+$O(^XTV(8992,XQAUSER,"XQA",0))))'>0,$G(XQAROUX)="^ " S XQAROU="" 10 AGAIN . S XQACHOIC="Y:YES;N:NO;C:CONTINUE;",XQAQ("?")="Enter Y (or C) to continue, N to exit alert processing" 11 . S XQACHOIC=$G(XQACHOIC)_"F:FORWARD ALERT;R:RENEW(MAKE NEW AGAIN);" S XQAQ("?",1)="Enter F to forward this alert to someone else",XQAQ("?",2)="Enter R to Renew (Make New) this alert" 12 . D I REASK=1 G AGAIN 13 . . S REASK=0 W !! K DIR S DIR(0)="SA^"_XQACHOIC,DIR("A")=$S(XQACHOIC["F:":"Continue (Y/N) or F(orward) or R(enew) ",1:"Continue Processing (Y/N) "),DIR("B")="YES" M DIR("?")=XQAQ("?") D ^DIR K DIR 14 . . I $D(DUOUT)!$D(DIRUT) S Y="N" K DUOUT,DIRUT 15 . . I Y="N" D:$D(XQAKILL) DELETEA^XQALERT K XQAID 16 . . I Y="R" S REASK=REASK+1 K XQAKILL I '$D(^XTV(8992,"AXQA",XQAID,DUZ)) D RESTORE 17 . . I Y="F" D:'$D(^XTV(8992,"AXQA",XQAID,DUZ)) RESTORE D FRWRDONE S REASK=REASK+1 18 . . Q 19 . Q 20 I $D(XQAKILL) D DELETEA^XQALERT 21 S XQAREV=1,XQXOUT=0,XQK=0,XQACNT=0 K XQADATA,XQAID,XQAROU,XQAKILL,XQAROUX 22 I '$D(XQX1) S XQX1=0 K ^TMP("XQ",$J,"XQA"),^("XQA1"),^("XQA2") I $O(^XTV(8992,XQAUSER,"XQA",0))'>0 K XQX1 D:'$G(^TMP("XQALERT1",$J,"NOTFIRST")) CHKSURO G:$O(^XTV(8992,XQAUSER,"XQA",0))'>0 EXIT S XQX1=0 ; P366 23 I $$ACTVSURO^XQALSURO(XQAUSER)'>0 D RETURN^XQALSUR1(XQAUSER) ; P366 24 S ^TMP("XQALERT1",$J,"NOTFIRST")=1 ; Added 2/2/99 jli to clear flag for initial entry 25 ;Sort and remove display only 26 I 'XQX1 W !!! D 27 . D SORT 28 ; Now display them. 29 SUBLOOP W @IOF 30 N XQZ1,XQZ 31 S XQK=0 F XQI=0:0 Q:XQX1!XQXOUT S XQI=$O(^TMP("XQ",$J,"XQA",XQI)) Q:XQI'>0 S XQX=^(XQI),XQII=^(XQI,1),XQZ=^(2),XQZ1=^(3) D I XQX'="" D DOIT1 32 . I '$D(^XTV(8992,XQAUSER,"XQA",XQII)) S XQX="" K ^TMP("XQ",$J,"XQA",XQI),^TMP("XQ",$J,"XQA1",(999999-XQI)) 33 . Q 34 S:'$D(XQXOUT) XQXOUT=0 G:XQXOUT EXIT G:XQK'>0&'XQX1 EXIT I 'XQX1 D ASK G:XQXOUT EXIT 35 G:+XQX1=0 EXIT I XQX1<0 S XQX1=0 G DOIT 36 I $D(XQALDELE)!$D(XQALFWD) Q 37 ;D WAIT(+XQX1) G:XQXOUT EXIT 38 G:XQXOUT EXIT 39 G EN^XQALDOIT 40 ; 41 RESTORE ; Restore a deleted message for use 42 N ALERTREF,XTVGLOB,ADUZ,X,X0,X1,X2,TIME,MESG,OPT,TAG,ROU 43 S XTVGLOB=$NA(^XTV(8992,DUZ,"XQA")) 44 S ADUZ=$O(^XTV(8992,"AXQA",XQAID,0)) I ADUZ>0 S TIME=$O(^(ADUZ,0)) D I 1 45 . M @XTVGLOB@(TIME)=^XTV(8992,ADUZ,"XQA",TIME) K @XTVGLOB@(TIME,2) ; copy alert, kill comment if any 46 E S ALERTREF=$O(^XTV(8992.1,"B",XQAID,0)) Q:ALERTREF'>0 D ; otherwise rebuild from alert tracking file if possible 47 . S X0=^XTV(8992.1,ALERTREF,0),X1=$G(^(1)),X2=$G(^(2)) 48 . S TIME=$P($P(X0,U),";",3),MESG=$P(X1,U),OPT=$P(X1,U,2),TAG=$P(X1,U,3),ROU=$P(X1,U,4) 49 . S X=TIME_U_XQAID_U_MESG_U_U_$S(OPT'=""!(ROU'=""):"R",1:"I")_U_U_$S(OPT'="":OPT,TAG'="":TAG,1:"")_U_$S(OPT'="":"",ROU'="":ROU,1:" ") 50 . S @XTVGLOB@(TIME,0)=X I $G(X2)'="" S ^(1)=X2 51 S ^XTV(8992,"AXQA",XQAID,DUZ,TIME)="",^XTV(8992,"AXQAN",$E($P(XQAID,";"),1,30),DUZ,TIME)="" 52 Q 53 ; 54 EXIT ; 55 I $G(XQALAST)="I",$G(DUZ("AUTO")) D WAIT2 56 I $D(XQALDELE)!$D(XQALFWD) Q 57 K ^TMP("XQ",$J,"XQA"),^("XQA1"),^("XQA2"),XQI,XQX,XQJ,XQK,XQX1,XQX2,XQXOUT,XQ1,XQII,XQACNT,XQA1,XQAREV,%ZIS,XQAROU,XQALAST,XQAROUX,XQON,XQOFF,XQ1ON,XQ1OFF,XQOUT,XQAQ 58 K ^TMP("XQALERT1",$J) 59 Q 60 ; 61 ; CHKSURO added 2/2/99 to give user opportunity to add/remove surrogate if no alerts present 62 CHKSURO ; If user selects process alerts with no alerts present, give him/her the opportunity to add or delete a surrogate 63 ; P366 - list currently established surrogates if any 64 I '$G(^TMP("XQALERT1",$J,"NOTFIRST")) W !!,"You have no alerts for processing.",! 65 D SURROGAT^XQALSURO ; XU*8*17 66 Q 67 ; 68 DOIT1 ; 69 I XQK=0 S XQALINFO=0 I '$D(XQALFWD) W @IOF 70 S XQON="$C(0)",XQOFF="$C(0)" S XQOUT=$P(XQX,U,3) I ($$UP^XLFSTR(XQOUT)["CRITICAL")!($$UP^XLFSTR(XQOUT)["ABNORMAL IMA") D:'$D(XQ1ON) SETREV^XQALERT S XQON=XQ1ON,XQOFF=XQ1OFF ; P285 71 S XQK=XQK+1 W !,$J(XQK,2),".",$S($P(XQX,U,8)=" ":"I",1:" ")," ",@XQON,$E($P(XQX,U,3),1,70),@XQOFF S:$P(XQX,U,8)=" " XQALINFO=XQALINFO+1 D:XQZ1'="" ; P285 72 . W !?8,"Forwarded by: ",$P(^VA(200,+XQZ1,0),U)," Generated: ",$$DAT8^XQALERT(+$P($P(XQX,U,2),";",3),1) 73 . I $P(XQZ1,U,3)'="" W !?8,$P(XQZ1,U,3) 74 S ^TMP("XQ",$J,"XQA1",XQK)=XQX,^(XQK,1)=XQII,^(2)=XQZ,^(3)=XQZ1 75 I ($Y+6)>IOSL N XQKVALUE S XQKVALUE=XQK D ASK0(XQI) S:'$D(XQK) XQK=XQKVALUE Q:XQX1!(XQXOUT) W @IOF 76 Q 77 ; 78 ASK0(XQI) ;Stack XQI 79 ASK ; 80 N XQALNEWF K XQALAST 81 ;I '$D(XQALDELE)&'$D(XQALFWD) S XQALNEWF=$P(^XTV(8992,XQAUSER,0),U,5) I XQALNEWF<20 D 82 ;. N XQALFDA 83 ;. S XQALNEWF=XQALNEWF+1,XQALFDA=(8992,(XQAUSER_","),.05)=XQALNEWF D FILE^DIE("","XQALFDA") 84 ;. W !,"NEW OPTIONS: S-to add/remove SURROGATE and D-to selectively Delete SOME alerts" 85 S XQ1=0,XQXOUT=0 W !?10,"Select from 1 to ",XQK W:$D(XQALDELE) " to DELETE" W:$D(XQALFWD) " to FORWARD" 86 W !?10,"or enter ?, A, " W:'$D(XQALDELE)&'$D(XQALFWD)&(XQALINFO>0) "I, D, " W:'$D(XQALDELE)&'$D(XQALFWD) "F, S, P, M, R, " W "or ^ to exit" I XQI>0,$O(^XTV(8992,XQAUSER,"XQA",XQI))>0 W !?10,"or RETURN to continue" S XQ1=1 87 R ": ",XQII:DTIME S:'$T!(XQII[U)!(XQII=""&'XQ1) XQXOUT=1 Q:XQXOUT 88 I '$D(XQALDELE)&'$D(XQALFWD),"PpMm"[$E(XQII_".") D MORP^XQALDOIT D:"Pp"[$E(XQII_".") PRINT^XQALDOIT D:"Mm"[$E(XQII_".") MAIL^XQALDOIT K ^TMP("XQ",$J,"XQA2") G ASK 89 I XQII'="",XQII["?" D HELP G ASK 90 I XQII=""&XQ1 Q 91 I "IiAaFfRrSsDd"'[$E(XQII_"."),$L(XQII)>31,$E(XQII,1,32)?1N.N W !,$C(7)," ?? Invalid number entered",! G ASK 92 I "IiAaFfRrSsDd"'[$E(XQII_"."),(XQII<1)!(XQII>XQK) W $C(7)," ??",! G ASK 93 I '$D(XQALDELE)&'$D(XQALFWD),"Ff"[$E(XQII) D FWRD^XQALFWD S XQX1=-2 Q ; MODIFIED 7-6 94 I '$D(XQALDELE)&'$D(XQALFWD),"Ss"[$E(XQII) D CHKSURO S XQX1=-1 Q 95 I '$D(XQALDELE)&'$D(XQALFWD),"Dd"[$E(XQII) D ASKDEL S XQX1=-2 Q ; MODIFIED 7-6 96 I '$D(XQALDELE),"Rr"[$E(XQII) S XQX1=-2 Q 97 I "Aa"[$E(XQII) S X="1-"_XQACNT,DIR(0)="LV^1:"_XQACNT D ^DIR K DIR,XQX1 M XQX1=Y S XQII="" K Y ;Merge list from Y 98 I XQII'="","Ii"[$E(XQII) S XQX1(0)="",XQX2=0,XQII="" F XQK=0:0 S XQK=$O(^TMP("XQ",$J,"XQA1",XQK)) S:XQK'>0 XQX1=XQX1(0) Q:XQK'>0 I $P(^(XQK),U,7,8)="^ " S XQX1(XQX2)=XQX1(XQX2)_XQK_"," S:$L(XQX1(XQX2))>240 XQX2=XQX2+1,XQX1(XQX2)="" 99 I XQII="" Q 100 S X=XQII,DIR(0)="LV^1:"_XQK D ^DIR I '$D(Y) W $C(7)," ??" D HELP G ASK ;Use of 'LV' is special 101 K XQX1 M XQX1=Y K Y S Y=XQX1 ;Merge list from Y 102 Q 103 WAIT(IFN) ;Wait for user input if last alert is INFO and next isn't. 104 N X,YY Q:$G(XQXOUT) 105 S X=$G(^TMP("XQ",$J,"XQA1",IFN)),YY=$P(X,U,7,8),YY=$S(YY="^ ":"I",YY="^":"O",1:"R") 106 I $G(XQALAST)="I","OR"[YY D WAIT2 107 I YY="I",$Y+4>IOSL D WAIT2 W @IOF 108 S XQALAST=YY 109 Q 110 WAIT2 ;Wait for user input before continuing 111 N DIR,Y,DIROUT,DIRUT S DIR(0)="E",DIR("?")="The next ALERT may cause the loss of info on the screen." 112 D ^DIR S:$D(DIRUT) XQXOUT=1 113 Q 114 ; 115 HELP W !!,"YOU MAY ENTER:",!?3,$S(XQK>1:"One or more numbers",1:"A number")," in the range 1 to ",XQK," to select specific alert(s)" 116 W !?6,"for "_$S($D(XQALDELE):"DELETION.",$D(XQALFWD):"FORWARDING",1:"processing.") W:XQK>1 " This may be a series of numbers, e.g., 2,3,6-9" 117 W !?3,"A to "_$S($D(XQALDELE):"DELETE",$D(XQALFWD):"FORWARD",1:"process")," all of the pending alerts in the order shown." 118 W:'$D(XQALDELE)&'$D(XQALFWD) !?3,"I to process all of the INFORMATION ONLY alerts, if any, without further ado." 119 W:'$D(XQALDELE)&'$D(XQALFWD) !?3,"S to add or remove a surrogate to receive alerts for you" 120 W:'$D(XQALDELE)&'$D(XQALFWD) !?3,"F to forward one or more specific alerts. Forwarding may be as an ALERT",!,"to specific user(s) and/or mail group(s), or as a MAIL MESSAGE, or to a",!,"specific PRINTER." 121 W:'$D(XQALDELE)&'$D(XQALFWD) !?3,"D to delete specific alerts (some alerts may not be deleted)" 122 W:'$D(XQALDELE)&'$D(XQALFWD) !?3,"P to print a copy of the pending alerts on a printer" 123 W:'$D(XQALDELE)&'$D(XQALFWD) !?3,"M to receive a MailMan message containing a copy of these pending alerts" 124 W:'$D(XQALDELE) !?3,"R to Redisplay the available alerts" 125 W !?3,"^ to exit" 126 I XQI W !?5,"or RETURN to see additional pending ALERTS" 127 W !! 128 Q 129 ; 130 SORT ;Sort and remove display only 131 F XQI=0:0 S XQI=$O(^XTV(8992,XQAUSER,"XQA",XQI)) Q:XQI'>0 S XQX=^(XQI,0),XQZ=$G(^(1)),XQZ1=$G(^(2)) S XQJ=$P(XQX,U,7,8) K:XQJ=U ^XTV(8992,XQAUSER,"XQA",XQI) I XQJ'=U D 132 . S XQACNT=XQACNT+1,XQJ=$S(XQAREV:999999-XQACNT,1:XQACNT),^TMP("XQ",$J,"XQA",XQJ)=XQX,^(XQJ,1)=XQI,^(2)=XQZ,^(3)=XQZ1 133 S XQK=0 F XQI=0:0 S XQI=$O(^TMP("XQ",$J,"XQA",XQI)) Q:XQI'>0 S XQK=XQK+1 M ^TMP("XQ",$J,"XQA1",XQK)=^TMP("XQ",$J,"XQA",XQI) 134 Q 135 ; 136 ASKDEL ; 137 N XQALDELE,XQX1COPY,XQAID,DA,XQAKILL,XQXOUT,XQAUSERD,XQALVALU 138 S XQALDELE=1 139 K XQX1 140 D DOIT^XQALERT1 141 K XQALDELE S XQAUSERD=1 142 I $D(XQX1),XQX1>0 D 143 . M XQX1COPY=XQX1 144 . F Q:XQX1="" S DA=+XQX1,XQX1=$P(XQX1,",",2,99) D I XQX1="" S Y=$O(XQX1(0)) I Y>0 S XQX1=XQX1(Y) K XQX1(Y) 145 . . S XQAID=$P(^TMP("XQ",$J,"XQA1",DA),U,2),XQALVALU=^(DA),XQAKILL=1 146 . . I $P(XQALVALU,U,8)=" "!$P(XQALVALU,U,10) D 147 . . . I XQAID="" K ^XTV(8992,XQAUSER,"XQA",+^TMP("XQ",$J,"XQA1",DA,1)) 148 . . . I XQAID'="" D DELETE^XQALDEL 149 . . . K ^TMP("XQ",$J,"XQA1",DA),^TMP("XQ",$J,"XQA",(999999-DA)) 150 . K XQX1 M XQX1=XQX1COPY S XQAID=0 151 . F Q:XQX1="" S DA=+XQX1,XQX1=$P(XQX1,",",2,99) D I XQX1="" S Y=$O(XQX1(0)) I Y>0 S XQX1=XQX1(Y) K XQX1(Y) 152 . . I $D(^TMP("XQ",$J,"XQA1",DA)) W:'XQAID !!,"Unable to delete alerts which require action: ",DA W:XQAID ",",DA S XQAID=1 153 . I XQAID=1 K DIR S DIR(0)="E" D ^DIR K DIR 154 K XQX1,XQAKILL 155 Q 156 ; 157 FRWRDONE ; 158 N XQX1,XQALFWDL S XQALFWDL(1)=XQAID 159 N XQAID 160 D FWDONE^XQALFWD 161 Q -
WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALMAKE.m
r613 r623 1 XQALMAKE ;ISC-SF.SEA/JLI- HIGH LEVEL SETUP ALERT ;4/9/07 14:03 2 ;;8.0;KERNEL;**443**;Jul 10, 1995;Build 4 3 ;; 4 ENTRY ; 5 W !!,"ALERT GENERATOR" 6 TEXT K XQA,XQAMSG,XQAOPT,XQAROU,DIC,DIR 7 R !!,"ON THE NEXT LINE ENTER THE TEXT TO BE DISPLAYED FOR THE ALERT ___",!,X:DTIME G:'$T!(X[U)!(X="") EXIT W !!,X S XQALX=X,DIR(0)="Y",DIR("A")="Is this text OK? ",DIR("B")="YES" D ^DIR K DIR G:'Y TEXT S XQAMSG=XQALX 8 D LOOP1 G:'$D(XQA) EXIT 9 ASKOPT S DIR(0)="Y",DIR("A")="Do you want to transfer control to an option when the alert is selected" D ^DIR K DIR I Y D GETOPT G:Y'="" SETIT G ASKOPT 10 ASKROU S DIR(0)="Y",DIR("A")="Do you want to transfer control to a routine when the alert is selected" D ^DIR K DIR G:'Y SETIT 11 R !,"Enter ROUTINE name or ENTRY^ROUTINE name: ",X:DTIME S:'$T X=U G:X=U EXIT G:X="" ASKROU S XQAROU=X S X=$S(X'[U:X,1:$P(X,U,2)) G:X="" ASKROU X ^%ZOSF("TEST") I 'Y W !,"Routine '",X,"' not present" G ASKROU 12 SETIT ; 13 I '$D(XQAROU),'$D(XQAOPT) S DIR(0)="Y",DIR("A")="Do you want to make a long text info only alert" D ^DIR K DIR I Y D LONGTEXT 14 W !!,"As currently entered, this alert will display the following text:",!!,XQAMSG 15 W !!,"The alert is currently to be delivered to:" S XQAX="" F I=1:1 S XQAX=$O(XQA(XQAX)) Q:XQAX="" S X=$S(XQAX>0:$P(^VA(200,XQAX,0),U),1:XQAX) W:(I#2) ! W:'(I#2) ?40 W X 16 W:$D(XQAROU) !!,"On selection of the alert, the user will run the routine ",XQAROU W:$D(XQAOPT) !!,"On selection of the alert, the user will be taken to the",!,"the option ",XQAOPT W !! 17 S DIR(0)="Y",DIR("A")="Is this alert what was intended",DIR("B")="YES" D ^DIR K DIR I 'Y G ENTRY 18 D SETUP^XQALERT 19 W !!?20,"ALERT IS NOW SET",!! 20 G ENTRY 21 ; 22 GETOPT ; 23 S DIC=19,DIC(0)="AEQM",DIC("A")="Indicate the desired OPTION: " D ^DIC K DIC S:Y'>0 Y="" S XQAOPT=$P(Y,U,2) 24 Q 25 ; 26 EXIT ; 27 K XQALDIC,XQALX,XQA,XQAMSG,XQAOPT,XQAROU,DIC,DIR,X,Y 28 Q 29 LOOP1 K XQA R !,"Enter a User name or G.mailgroup",!,"as recipient of the Alert: ",X:DTIME S:'$T!(X="") X=U I X'[U D SETONE G:Y'>0 LOOP1 30 I X'[U F R !,"Enter another user or G.mailgroup: ",X:DTIME S:'$T X=U Q:X[U!(X="") D SETONE 31 K:X[U XQA Q 32 SETONE ; 33 S XQALDIC=$S("g.G."[$E(X,1,2):3.8,1:200),X=$S(XQALDIC=3.8:$E(X,3,$L(X)),1:X),DIC=XQALDIC,DIC(0)="EMQ" D ^DIC Q:Y'>0 S X=$S(XQALDIC=3.8:"G."_$P(Y,U,2),1:+Y),XQA(X)="" 34 Q 35 ; 36 LONGTEXT ; 37 W !,"Enter .EXIT to terminate input",! 38 S COUNT="" F R X:DTIME Q:X=".EXIT" S COUNT=COUNT+1,XQATEXT(COUNT)=X W ! 39 Q 1 XQALMAKE ;ISC-SF.SEA/JLI- HIGH LEVEL SETUP ALERT ;9/23/94 13:28 2 ;;8.0;KERNEL;;Jul 10, 1995 3 ;; 4 ENTRY ; 5 W !!,"ALERT GENERATOR" 6 TEXT K XQA,XQAMSG,XQAOPT,XQAROU,DIC,DIR 7 R !!,"ON THE NEXT LINE ENTER THE TEXT TO BE DISPLAYED FOR THE ALERT ___",!,X:DTIME G:'$T!(X[U)!(X="") EXIT W !!,X S XQALX=X,DIR(0)="Y",DIR("A")="Is this text OK? ",DIR("B")="YES" D ^DIR K DIR G:'Y TEXT S XQAMSG=XQALX 8 D LOOP1 G:'$D(XQA) EXIT 9 ASKOPT S DIR(0)="Y",DIR("A")="Do you want to transfer control to an option when the alert is selected" D ^DIR K DIR I Y D GETOPT G:Y'="" SETIT G ASKOPT 10 ASKROU S DIR(0)="Y",DIR("A")="Do you want to transfer control to a routine when the alert is selected" D ^DIR K DIR G:'Y SETIT 11 R !,"Enter ROUTINE name or ENTRY^ROUTINE name: ",X:DTIME S:'$T X=U G:X=U EXIT G:X="" ASKROU S XQAROU=X S X=$S(X'[U:X,1:$P(X,U,2)) G:X="" ASKROU X ^%ZOSF("TEST") I 'Y W !,"Routine '",X,"' not present" G ASKROU 12 SETIT ; 13 W !!,"As currently entered, this alert will display the following text:",!!,XQAMSG 14 W !!,"The alert is currently to be delivered to:" S XQAX="" F I=1:1 S XQAX=$O(XQA(XQAX)) Q:XQAX="" S X=$S(XQAX>0:$P(^VA(200,XQAX,0),U),1:XQAX) W:(I#2) ! W:'(I#2) ?40 W X 15 W:$D(XQAROU) !!,"On selection of the alert, the user will run the routine ",XQAROU W:$D(XQAOPT) !!,"On selection of the alert, the user will be taken to the",!,"the option ",XQAOPT W !! 16 S DIR(0)="Y",DIR("A")="Is this alert what was intended",DIR("B")="YES" D ^DIR K DIR I 'Y G ENTRY 17 D SETUP^XQALERT 18 W !!?20,"ALERT IS NOW SET",!! 19 G ENTRY 20 ; 21 GETOPT ; 22 S DIC=19,DIC(0)="AEQM",DIC("A")="Indicate the desired OPTION: " D ^DIC K DIC S:Y'>0 Y="" S XQAOPT=$P(Y,U,2) 23 Q 24 ; 25 EXIT ; 26 K XQALDIC,XQALX,XQA,XQAMSG,XQAOPT,XQAROU,DIC,DIR,X,Y 27 Q 28 LOOP1 K XQA R !,"Enter a User name or G.mailgroup",!,"as recipient of the Alert: ",X:DTIME S:'$T!(X="") X=U I X'[U D SETONE G:Y'>0 LOOP1 29 I X'[U F R !,"Enter another user or G.mailgroup: ",X:DTIME S:'$T X=U Q:X[U!(X="") D SETONE 30 K:X[U XQA Q 31 SETONE ; 32 S XQALDIC=$S("g.G."[$E(X,1,2):3.8,1:200),X=$S(XQALDIC=3.8:$E(X,3,$L(X)),1:X),DIC=XQALDIC,DIC(0)="EMQ" D ^DIC Q:Y'>0 S X=$S(XQALDIC=3.8:"G."_$P(Y,U,2),1:+Y),XQA(X)="" 33 Q -
WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALSET.m
r613 r623 1 XQALSET ;ISC-SF.SEA/JLI - SETUP ALERTS ;4/10/07 14:06 2 ;;8.0;KERNEL;**1,6,65,75,114,125,173,207,285,443**;Jul 10, 1995;Build 4 3 ;; 4 Q 5 ; Original entry point - throw away return value since no value expected 6 SETUP ; 7 N I S I=$$SETUP1() K XQALERR 8 Q 9 ; 10 SETUP1() ; .SR Returns a string beginning with 1 if successful, 0 if not successful, the second piece is the IEN in the Alert Tracking File and the third piece is the value of XQAID. 11 ; If not successful XQALERR is defined and contains reason for failure. 12 K XQALERR 13 I $O(XQA(0))="" S XQALERR="No recipient list in XQA array" Q 0 14 I '($D(XQAMSG)#2)!($G(XQAMSG)="") S XQALERR="No valid XQAMSG for display" Q 0 15 N X,XQI,XQJ,XQX,XQK,XQACOMNT,XQARESET,DA,XQADA,XQALTYPE 16 S XQALTYPE="INITIAL RECIPIENT" 17 S XQAOPT1=$S('($D(XQAROU)#2):U,XQAROU'[U:U_XQAROU,1:XQAROU),XQAOPT1=$S(XQAOPT1'=U:XQAOPT1,$D(XQAOPT)#2:XQAOPT_U,1:XQAOPT1) S:XQAOPT1=U XQAOPT1=U_" " 18 NOW S XQX=$$NOW^XLFDT() 19 S:$S('$D(XQAID):1,XQAID="":1,1:0) XQAID="NO-ID" S:XQAID[";" XQAID=$P(XQAID,";") S XQA1=XQAID,XQI=XQX 20 S XQAID=$$SETIEN(XQA1,XQX),XQADA="" 21 Q $$REENT() 22 ; 23 REENT() ; Entry for forwarding, etc. 24 N RETVAL S RETVAL=1 25 K ^TMP("XQAGROUP",$J) ; P443 - clear location for storage of groups processed 26 N XQADATIM,XQALIST,XQALIST1,XQNRECIP S XQNRECIP=0 S XQADATIM=$$NOW^XLFDT() 27 S XQALIN1=$S($D(XQAID)#2:XQAID,1:"")_U_$E(XQAMSG,1,80)_"^1^"_$S(XQAOPT1=U:"D",1:"R")_U_$S($D(XQACTMSG):$E(XQACTMSG,1,40),1:"")_U_XQAOPT1 28 S:$D(XQACNDEL) $P(XQALIN1,U,9)=1 S:$D(XQASURO) $P(XQALIN1,U,12)=XQASURO S:$D(XQASUPV) $P(XQALIN1,U,13)=XQASUPV S:$D(XQAREVUE) $P(XQALIN1,U,14)=XQAREVUE 29 S XQALIN=XQX_U_XQALIN1,XQJ=0 30 K XQALIN1 S:$D(XQADATA) XQALIN1=XQADATA 31 LOOP1 S XQJ=$O(XQA(" ")) I XQJ'="" K:"G.g."'[$E(XQJ_",,",1,2) XQA(XQJ) D:$D(XQA(XQJ)) GROUP^XQALSET1 G LOOP1 32 LOOP2 ; RE-ENTRY FOR FORWARDING IF ALL RECIPIENTS ARE UNDELIVERABLE 33 N:'$D(XQAUSER) XQAUSER M XQALIST=XQA F I=0:0 S I=$O(XQALIST(I)) Q:I'>0 S XQALIST(I,XQALTYPE)="" I '$D(XQAUSER) S XQAUSER=I ; SAVE ORIGINAL LIST OF RECIPIENTS AND REASON 34 ; The following section of code was added to provide a generalized way to handle surrogates 35 F XQJ=0:0 S XQJ=$O(XQA(XQJ)) Q:XQJ="" D 36 . N X S X=$$ACTVSURO^XQALSURO(XQJ) I X>0 D ; Modified to get final surrogate if a sequence of them 37 . . S XQA(X)="" K XQA(XQJ) ; Add Surrogate to XQA array, delete XQJ entry 38 . . S XQALIST(X,$O(XQALIST(XQJ,""))_"-SURROGATE")="" ; Add Surrogate to XQALIST with same type as original 39 . . S XQALIST(X,"z AS_SURO",XQJ)="" ; Mark user as in list as a surrogate, subscript for surrogate to 40 . . S XQALIST(XQJ,"z TO_SURO",X)="" 41 . . Q 42 . Q 43 ; 44 S XQJ=0 45 LOOP ; 46 S XQJ=$O(XQA(XQJ)) G:XQJ="" WRAP 47 ; 48 I '(+$$ACTIVE^XUSER(XQJ)) K XQA(XQJ) N XX S XX=$O(XQALIST(XQJ,"")) K XQALIST(XQJ,XX) S XQALIST(XQJ,XX_"-UNDELIVERABLE")="" G LOOP ;Don't send to users that can't sign-on 49 ; 50 I '$D(^XTV(8992,XQJ,0)) D I '$D(^XTV(8992,XQJ,0)) S ^(0)=XQJ 51 . N FDA,IENS 52 . F D Q:'$D(DIERR) Q:'$D(^TMP("DIERR",$J,"E",110))&'$D(^TMP("DIERR",$J,"E",111)) 53 . . K DIERR,^TMP("DIERR",$J) 54 . . S FDA=$NA(^TMP($J,"XQALSET")) K @FDA S @FDA@(8992,"+1,",.01)=XQJ 55 . . S IENS(1)=XQJ 56 . . D UPDATE^DIE("S",FDA,"IENS") 57 . . Q 58 . Q 59 L +^XTV(8992,XQJ):10 S XQXI=XQX S:'$D(^XTV(8992,XQJ,"XQA",0)) ^(0)="^8992.01DA^" 60 REP I $D(^XTV(8992,XQJ,"XQA",XQXI,0)) S XQXI=XQXI+.00000001 G REP 61 S ^XTV(8992,XQJ,"XQA",XQXI,0)=XQALIN S:$D(XQALIN1) ^(1)=XQALIN1 S:$D(XQAGUID)!$D(XQADFN) ^(3)=$G(XQAGUID)_U_$G(XQADFN) S:$D(XQARESET) ^(2)=XQAUSER_U_XQX_U_$G(XQACOMNT) S ^(0)=$P(^XTV(8992,XQJ,"XQA",0),U,1,2)_U_XQXI_U_($P(^(0),U,4)+1) 62 I $D(XQATEXT) S:($D(XQATEXT)#2) XQATEXT(.1)=XQATEXT D WP^DIE(8992.01,(XQXI_","_XQJ_","),4,"","XQATEXT") ; P443 PUT DATA IN XQATEXT INTO ARRAY 63 L -^XTV(8992,XQJ) 64 K XQA(XQJ) S:XQAID'="" ^XTV(8992,"AXQA",XQAID,XQJ,XQXI)="",^XTV(8992,"AXQAN",XQA1,XQJ,XQXI)="" 65 S XQNRECIP=XQNRECIP+1 66 G LOOP 67 ; 68 WRAP ; 69 M XQALIST1=XQALIST 70 I XQNRECIP=0,'$$SNDNACTV(XQAID) S RETVAL=0,XQALERR="NO ACTIVE RECIPIENTS - OLDER TIU ALERTS" 71 E I XQNRECIP=0 D I $D(XQA) S XQACOMNT=$E("None of recipients were active users. "_$G(XQACOMNT),1,245),XQNRECIP=1,XQARESET=1 K XQALIST G LOOP2 ; SET NUMBER OF RECIPIENTS TO 1 SO WE WON'T COME HERE AGAIN 72 . N XQAA,XQJ F XQI=0:0 S XQI=$O(XQALIST(XQI)) Q:XQI'>0 D GETBKUP^XQALDEL(.XQAA,XQI) S XQALTYPE="BACKUP REVIEWER" F XQJ=0:0 S XQJ=$O(XQAA(XQJ)) Q:XQJ'>0 S XQA(XQAA(XQJ))="" 73 . I $D(XQA) D CHEKACTV^XQALSET1(.XQA) 74 . I '$D(XQA) S XQJ="G.XQAL UNPROCESSED ALERTS" D GROUP^XQALSET1 S XQALTYPE="UNPROCESSED ALERTS MAIL GROUP" ;D GETMLGRP(.XQA,XQI) ; COULDN'T FIND ANY BACKUP, GET A MAILGROUP AND MEMBERS TO SEND IT TO 75 . I '$D(XQA) S XQJ="G.PATCHES" D GROUP^XQALSET1 S XQALTYPE="LAST HOPE" ; Last gasp, send it to G.PATCHES 76 . I '$D(XQA) S XQJ="G.PATCH" D GROUP^XQALSET1 S XQALTYPE="LAST HOPE" ; Last gasp, send it to G.PATCH 77 . I '$D(XQA) S RETVAL=0,XQALERR="Could not find any active user to send it to" ; Should not get here, this is only if all backups and mail groups tried don't have any active users 78 . Q 79 ; END OF JLI 030129 INSERTION P285 80 ; moved recording of users in Alert Tracking file to here to include all of them 030220 81 ; modified code to use FM calls instead of direct global references 82 I RETVAL,$G(XQADA)'>0,XQAID'="" D SETTRACK ; moved to here to avoid tracking entries with no users 83 ; 84 I RETVAL,$G(XQADA)>0 L +^XTV(8992.1,XQADA):10 D L -^XTV(8992.1,XQADA) ; 030131 85 . F XQJ=0:0 S XQJ=$O(XQALIST1(XQJ)) Q:XQJ'>0 D 86 . . N NCOUNT,SUBSCRPT,SUBSCRPN,KCNT,IENVAL 87 . . S IENVAL=XQADA_",",KCNT=$$FIND1^DIC(8992.11,","_IENVAL,"Q",XQJ) 88 . . S FDA=$NA(^TMP($J,"XQALSET")) K @FDA I KCNT=0 S @FDA@(8992.11,"+1,"_IENVAL,.01)=XQJ,KCNT="+1" 89 . . S IENVAL=","_KCNT_","_IENVAL,NCOUNT=1 S SUBSCRPT="" F S SUBSCRPT=$O(XQALIST1(XQJ,SUBSCRPT)) Q:SUBSCRPT="" I $E(SUBSCRPT,1)'="z" D 90 . . . S SUBSCRPN=$$FIND1^DIC(8992.2,"","X",SUBSCRPT) I SUBSCRPN'>0 D 91 . . . . N FDA1,IENROOT S FDA1=$NA(^TMP($J,"XQALSET1")) K @FDA1 S @FDA1@(8992.2,"+1,",.01)=SUBSCRPT D UPDATE^DIE("",FDA1,"IENROOT") S SUBSCRPN=$G(IENROOT(1)) 92 . . . . Q 93 . . . S NCOUNT=NCOUNT+1,@FDA@(8992.111,"+"_NCOUNT_IENVAL,.01)=SUBSCRPN,@FDA@(8992.111,"+"_NCOUNT_IENVAL,.04)=XQADATIM 94 . . . Q 95 . . I $D(XQALIST1(XQJ,"z TO_SURO")) S @FDA@(8992.111,"+"_NCOUNT_IENVAL,.02)=$O(XQALIST1(XQJ,"z TO_SURO",0)) 96 . . I $D(XQALIST1(XQJ,"z AS_SURO")) D 97 . . . S @FDA@(8992.111,"+"_NCOUNT_IENVAL,.03)="Y" 98 . . . N XQK S NCOUNT=NCOUNT+1 F XQK=0:0 S XQK=$O(XQALIST1(XQJ,"z AS_SURO",XQK)) Q:XQK'>0 S @FDA@(8992.113,"+"_NCOUNT_IENVAL,.01)=XQK,@FDA@(8992.113,"+"_NCOUNT_IENVAL,.02)=XQADATIM 99 . . . Q 100 . . S SUBSCRPT=$O(XQALIST1(XQJ,"")) I SUBSCRPT'["INITIAL" S SUBSCRPT=$P(SUBSCRPT,"-") D ; FORWARDING 101 . . . S SUBSCRPN=$$FIND1^DIC(8992.2,"","X",SUBSCRPT) I SUBSCRPN'>0 D 102 . . . . N FDA1,IENROOT S FDA1=$NA(^TMP($J,"XQALSET1")) K @FDA1 S @FDA1@(8992.2,"+1,",.01)=SUBSCRPT D UPDATE^DIE("",FDA1,"IENROOT") S SUBSCRPN=$G(IENROOT(1)) 103 . . . . Q 104 . . . S NCOUNT=NCOUNT+1,@FDA@(8992.112,"+"_NCOUNT_IENVAL,.01)=XQADATIM,@FDA@(8992.112,"+"_NCOUNT_IENVAL,.02)=SUBSCRPN I $G(XQACOMNT)'="" S @FDA@(8992.112,"+"_NCOUNT_IENVAL,1.01)=XQACOMNT 105 . . . I $G(XQAUSER)>0 S @FDA@(8992.112,"+"_NCOUNT_IENVAL,.03)=XQAUSER 106 . . . Q 107 . . N IENSTR D UPDATE^DIE("",FDA,"IENSTR") 108 . . Q 109 . Q 110 ; 111 I RETVAL S RETVAL=RETVAL_U_$G(XQADA)_U_XQAID 112 K:XQAID'="" ^XTV(8992,"AXQA",XQAID,0,0) 113 K ^TMP("XQAGROUP",$J) ; P443 - clear global used to track processing of groups 114 K XQA,XQALIN,XQALIN1,XQAMSG,XQAID,XQAFLG,XQAOPT,XQAOPT1,XQAROU,XQADATA,XQI,XQX,XQJ,XQK,XQA1,XQACTMSG,XQJ,XQXI,XQAARCH,XQACNDEL,XQAREVUE,XQASUPV,XQASURO,XQATEXT 115 Q RETVAL 116 ; 117 SNDNACTV(XQAID) ; Determine if we go ahead and send alerts addressed only to inactive users to backup reviewers 118 N XVAL 119 I $E(XQAID,1,3)="TIU" S XVAL=$E($P(XQAID,";"),4,99),XVAL=$$GET1^DIQ(8925,XVAL_",",1201,"I") I XVAL>0,$$FMDIFF^XLFDT(DT,XVAL)>60 Q 0 120 Q 1 121 ; 122 SETIEN(XQA1,XQI) ; determine unique XQAID value for alert 123 N XQAID 124 S:$G(XQA1)="" XQA1="NO-ID" F S XQAID=XQA1_";"_DUZ_";"_XQI L +^XTV(8992,"AXQA",XQAID):10 D L -^XTV(8992,"AXQA",XQAID) Q:XQI="" S XQI=XQI+.00000001 125 . I $D(^XTV(8992,"AXQA",XQAID)) Q 126 . S ^XTV(8992,"AXQA",XQAID,0,0)="",XQI="" 127 . Q 128 Q XQAID 129 ; 130 SETTRACK ; Setup entry in Alert Tracking file 131 ; Note: if there are error messages or we can't create an entry for some reason, it simply returns and continues 132 N FDA,IENS,XQA2,DIERR 133 S XQADA=0 134 S XQA2=XQA1 I XQA2[",",$P(XQA2,",",3)'="" S XQA2=$P(XQA2,",")_","_$P(XQA2,",",3) 135 F D Q:'$D(DIERR) Q:'$D(^TMP("DIERR",$J,"E",111)) 136 . K DIERR,^TMP("DIERR",$J) 137 . S FDA=$NA(^TMP($J,"XQALSET")) K @FDA 138 . S @FDA@(8992.1,"+1,",.01)=XQAID D UPDATE^DIE("",FDA,"IENS") 139 . K @FDA 140 . Q 141 I $D(DIERR) Q ;S XQDIERR1=DIERR M XQDIERR=^TMP("DIERR",$J) Q 142 Q:IENS(1)'>0 S (DA,XQADA)=IENS(1) 143 S IENS=IENS(1)_",",@FDA@(8992.1,IENS,.02)=XQX,^(.03)=XQA2,^(.05)=DUZ,^(1.01)=XQAMSG 144 I $D(XQAARCH) S X=$$FMADD^XLFDT(DT,XQAARCH) I X>DT S @FDA@(8992.1,IENS,.08)=X 145 I $P(XQA1,",")="OR",$P(XQA1,",",2)>0 S @FDA@(8992.1,IENS,.04)=$P(XQA1,",",2) 146 I $D(ZTQUEUED) S @FDA@(8992.1,IENS,.06)=1 147 I $D(XQAOPT)#2 S @FDA@(8992.1,IENS,1.02)=XQAOPT 148 I $D(XQAROU)#2 N XQAXX S XQAXX=$S(XQAROU[U:XQAROU,1:U_XQAROU) I $P(XQAXX,U,2)'="" S:$P(XQAXX,U)'="" @FDA@(8992.1,IENS,1.03)=$P(XQAXX,U) S @FDA@(8992.1,IENS,1.04)=$P(XQAXX,U,2) 149 I $D(XQACTMSG) S @FDA@(8992.1,IENS,1.05)=XQACTMSG 150 I $D(XQADATA) S @FDA@(8992.1,IENS,2)=XQADATA 151 I $D(XQAGUID) S @FDA@(8992.1,IENS,3.01)=XQAGUID 152 I $D(XQADFN) S @FDA@(8992.1,IENS,.04)=XQADFN 153 D FILE^DIE("KS",FDA) 154 I $D(XQATEXT) D WP^DIE(8992.1,IENS,4,"","XQATEXT") 155 Q 156 ; 157 CHEKUSER(XQAUSER) ; .SR Returns 0 if no valid user or surrogate, otherwise returns IEN of user or surrogate 158 Q $$CHEKUSER^XQALSET1(XQAUSER) 159 ; 1 XQALSET ;ISC-SF.SEA/JLI - SETUP ALERTS ;6/24/04 13:46 2 ;;8.0;KERNEL;**1,6,65,75,114,125,173,207,285**;Jul 10, 1995 3 ;; 4 Q 5 ; Original entry point - throw away return value since no value expected 6 SETUP ; 7 N I S I=$$SETUP1() K XQALERR 8 Q 9 ; 10 SETUP1() ; .SR Returns a string beginning with 1 if successful, 0 if not successful, the second piece is the IEN in the Alert Tracking File and the third piece is the value of XQAID. 11 ; If not successful XQALERR is defined and contains reason for failure. 12 K XQALERR 13 I $O(XQA(0))="" S XQALERR="No recipient list in XQA array" Q 0 14 I '($D(XQAMSG)#2)!($G(XQAMSG)="") S XQALERR="No valid XQAMSG for display" Q 0 15 N X,XQI,XQJ,XQX,XQK,XQACOMNT,XQARESET,DA,XQADA,XQALTYPE 16 S XQALTYPE="INITIAL RECIPIENT" 17 S XQAOPT1=$S('($D(XQAROU)#2):U,XQAROU'[U:U_XQAROU,1:XQAROU),XQAOPT1=$S(XQAOPT1'=U:XQAOPT1,$D(XQAOPT)#2:XQAOPT_U,1:XQAOPT1) S:XQAOPT1=U XQAOPT1=U_" " 18 NOW S XQX=$$NOW^XLFDT() 19 S:$S('$D(XQAID):1,XQAID="":1,1:0) XQAID="NO-ID" S:XQAID[";" XQAID=$P(XQAID,";") S XQA1=XQAID,XQI=XQX 20 S XQAID=$$SETIEN(XQA1,XQX),XQADA="" 21 Q $$REENT() 22 ; 23 REENT() ; Entry for forwarding, etc. 24 N RETVAL S RETVAL=1 25 N XQADATIM,XQALIST,XQALIST1,XQNRECIP S XQNRECIP=0 S XQADATIM=$$NOW^XLFDT() 26 S XQALIN1=$S($D(XQAID)#2:XQAID,1:"")_U_$E(XQAMSG,1,80)_"^1^"_$S(XQAOPT1=U:"D",1:"R")_U_$S($D(XQACTMSG):$E(XQACTMSG,1,40),1:"")_U_XQAOPT1 27 S:$D(XQACNDEL) $P(XQALIN1,U,9)=1 S:$D(XQASURO) $P(XQALIN1,U,12)=XQASURO S:$D(XQASUPV) $P(XQALIN1,U,13)=XQASUPV S:$D(XQAREVUE) $P(XQALIN1,U,14)=XQAREVUE 28 S XQALIN=XQX_U_XQALIN1,XQJ=0 29 K XQALIN1 S:$D(XQADATA) XQALIN1=XQADATA 30 LOOP1 S XQJ=$O(XQA(" ")) I XQJ'="" K:"G.g."'[$E(XQJ_",,",1,2) XQA(XQJ) D:$D(XQA(XQJ)) GROUP^XQALSET1 G LOOP1 31 LOOP2 ; RE-ENTRY FOR FORWARDING IF ALL RECIPIENTS ARE UNDELIVERABLE 32 N:'$D(XQAUSER) XQAUSER M XQALIST=XQA F I=0:0 S I=$O(XQALIST(I)) Q:I'>0 S XQALIST(I,XQALTYPE)="" I '$D(XQAUSER) S XQAUSER=I ; SAVE ORIGINAL LIST OF RECIPIENTS AND REASON 33 ; The following section of code was added to provide a generalized way to handle surrogates 34 F XQJ=0:0 S XQJ=$O(XQA(XQJ)) Q:XQJ="" D 35 . N X S X=$$ACTVSURO^XQALSURO(XQJ) I X>0 D ; Modified to get final surrogate if a sequence of them 36 . . S XQA(X)="" K XQA(XQJ) ; Add Surrogate to XQA array, delete XQJ entry 37 . . S XQALIST(X,$O(XQALIST(XQJ,""))_"-SURROGATE")="" ; Add Surrogate to XQALIST with same type as original 38 . . S XQALIST(X,"z AS_SURO",XQJ)="" ; Mark user as in list as a surrogate, subscript for surrogate to 39 . . S XQALIST(XQJ,"z TO_SURO",X)="" 40 . . Q 41 . Q 42 ; 43 S XQJ=0 44 LOOP ; 45 S XQJ=$O(XQA(XQJ)) G:XQJ="" WRAP 46 ; 47 I '(+$$ACTIVE^XUSER(XQJ)) K XQA(XQJ) N XX S XX=$O(XQALIST(XQJ,"")) K XQALIST(XQJ,XX) S XQALIST(XQJ,XX_"-UNDELIVERABLE")="" G LOOP ;Don't send to users that can't sign-on 48 ; 49 I '$D(^XTV(8992,XQJ,0)) D I '$D(^XTV(8992,XQJ,0)) S ^(0)=XQJ 50 . N FDA,IENS 51 . F D Q:'$D(DIERR) Q:'$D(^TMP("DIERR",$J,"E",110))&'$D(^TMP("DIERR",$J,"E",111)) 52 . . K DIERR,^TMP("DIERR",$J) 53 . . S FDA=$NA(^TMP($J,"XQALSET")) K @FDA S @FDA@(8992,"+1,",.01)=XQJ 54 . . S IENS(1)=XQJ 55 . . D UPDATE^DIE("S",FDA,"IENS") 56 . . Q 57 . Q 58 L +^XTV(8992,XQJ):10 S XQXI=XQX S:'$D(^XTV(8992,XQJ,"XQA",0)) ^(0)="^8992.01DA^" 59 REP I $D(^XTV(8992,XQJ,"XQA",XQXI,0)) S XQXI=XQXI+.00000001 G REP 60 S ^XTV(8992,XQJ,"XQA",XQXI,0)=XQALIN S:$D(XQALIN1) ^(1)=XQALIN1 S:$D(XQAGUID)!$D(XQADFN) ^(3)=$G(XQAGUID)_U_$G(XQADFN) S:$D(XQARESET) ^(2)=XQAUSER_U_XQX_U_$G(XQACOMNT) S ^(0)=$P(^XTV(8992,XQJ,"XQA",0),U,1,2)_U_XQXI_U_($P(^(0),U,4)+1) 61 I $D(XQATEXT) D WP^DIE(8992.01,(XQXI_","_XQJ_","),4,"","XQATEXT") 62 L -^XTV(8992,XQJ) 63 K XQA(XQJ) S:XQAID'="" ^XTV(8992,"AXQA",XQAID,XQJ,XQXI)="",^XTV(8992,"AXQAN",XQA1,XQJ,XQXI)="" 64 S XQNRECIP=XQNRECIP+1 65 G LOOP 66 ; 67 WRAP ; 68 M XQALIST1=XQALIST 69 I XQNRECIP=0,'$$SNDNACTV(XQAID) S RETVAL=0,XQALERR="NO ACTIVE RECIPIENTS - OLDER TIU ALERTS" 70 E I XQNRECIP=0 D I $D(XQA) S XQACOMNT=$E("None of recipients were active users. "_$G(XQACOMNT),1,245),XQNRECIP=1,XQARESET=1 K XQALIST G LOOP2 ; SET NUMBER OF RECIPIENTS TO 1 SO WE WON'T COME HERE AGAIN 71 . N XQAA,XQJ F XQI=0:0 S XQI=$O(XQALIST(XQI)) Q:XQI'>0 D GETBKUP^XQALDEL(.XQAA,XQI) S XQALTYPE="BACKUP REVIEWER" F XQJ=0:0 S XQJ=$O(XQAA(XQJ)) Q:XQJ'>0 S XQA(XQAA(XQJ))="" 72 . I $D(XQA) D CHEKACTV^XQALSET1(.XQA) 73 . I '$D(XQA) S XQJ="G.XQAL UNPROCESSED ALERTS" D GROUP^XQALSET1 S XQALTYPE="UNPROCESSED ALERTS MAIL GROUP" ;D GETMLGRP(.XQA,XQI) ; COULDN'T FIND ANY BACKUP, GET A MAILGROUP AND MEMBERS TO SEND IT TO 74 . I '$D(XQA) S XQJ="G.PATCHES" D GROUP^XQALSET1 S XQALTYPE="LAST HOPE" ; Last gasp, send it to G.PATCHES 75 . I '$D(XQA) S XQJ="G.PATCH" D GROUP^XQALSET1 S XQALTYPE="LAST HOPE" ; Last gasp, send it to G.PATCH 76 . I '$D(XQA) S RETVAL=0,XQALERR="Could not find any active user to send it to" ; Should not get here, this is only if all backups and mail groups tried don't have any active users 77 . Q 78 ; END OF JLI 030129 INSERTION P285 79 ; moved recording of users in Alert Tracking file to here to include all of them 030220 80 ; modified code to use FM calls instead of direct global references 81 I RETVAL,$G(XQADA)'>0,XQAID'="" D SETTRACK ; moved to here to avoid tracking entries with no users 82 ; 83 I RETVAL,$G(XQADA)>0 L +^XTV(8992.1,XQADA):10 D L -^XTV(8992.1,XQADA) ; 030131 84 . F XQJ=0:0 S XQJ=$O(XQALIST1(XQJ)) Q:XQJ'>0 D 85 . . N NCOUNT,SUBSCRPT,SUBSCRPN,KCNT,IENVAL 86 . . S IENVAL=XQADA_",",KCNT=$$FIND1^DIC(8992.11,","_IENVAL,"Q",XQJ) 87 . . S FDA=$NA(^TMP($J,"XQALSET")) K @FDA I KCNT=0 S @FDA@(8992.11,"+1,"_IENVAL,.01)=XQJ,KCNT="+1" 88 . . S IENVAL=","_KCNT_","_IENVAL,NCOUNT=1 S SUBSCRPT="" F S SUBSCRPT=$O(XQALIST1(XQJ,SUBSCRPT)) Q:SUBSCRPT="" I $E(SUBSCRPT,1)'="z" D 89 . . . S SUBSCRPN=$$FIND1^DIC(8992.2,"","X",SUBSCRPT) I SUBSCRPN'>0 D 90 . . . . N FDA1,IENROOT S FDA1=$NA(^TMP($J,"XQALSET1")) K @FDA1 S @FDA1@(8992.2,"+1,",.01)=SUBSCRPT D UPDATE^DIE("",FDA1,"IENROOT") S SUBSCRPN=$G(IENROOT(1)) 91 . . . . Q 92 . . . S NCOUNT=NCOUNT+1,@FDA@(8992.111,"+"_NCOUNT_IENVAL,.01)=SUBSCRPN,@FDA@(8992.111,"+"_NCOUNT_IENVAL,.04)=XQADATIM 93 . . . Q 94 . . I $D(XQALIST1(XQJ,"z TO_SURO")) S @FDA@(8992.111,"+"_NCOUNT_IENVAL,.02)=$O(XQALIST1(XQJ,"z TO_SURO",0)) 95 . . I $D(XQALIST1(XQJ,"z AS_SURO")) D 96 . . . S @FDA@(8992.111,"+"_NCOUNT_IENVAL,.03)="Y" 97 . . . N XQK S NCOUNT=NCOUNT+1 F XQK=0:0 S XQK=$O(XQALIST1(XQJ,"z AS_SURO",XQK)) Q:XQK'>0 S @FDA@(8992.113,"+"_NCOUNT_IENVAL,.01)=XQK,@FDA@(8992.113,"+"_NCOUNT_IENVAL,.02)=XQADATIM 98 . . . Q 99 . . S SUBSCRPT=$O(XQALIST1(XQJ,"")) I SUBSCRPT'["INITIAL" S SUBSCRPT=$P(SUBSCRPT,"-") D ; FORWARDING 100 . . . S SUBSCRPN=$$FIND1^DIC(8992.2,"","X",SUBSCRPT) I SUBSCRPN'>0 D 101 . . . . N FDA1,IENROOT S FDA1=$NA(^TMP($J,"XQALSET1")) K @FDA1 S @FDA1@(8992.2,"+1,",.01)=SUBSCRPT D UPDATE^DIE("",FDA1,"IENROOT") S SUBSCRPN=$G(IENROOT(1)) 102 . . . . Q 103 . . . S NCOUNT=NCOUNT+1,@FDA@(8992.112,"+"_NCOUNT_IENVAL,.01)=XQADATIM,@FDA@(8992.112,"+"_NCOUNT_IENVAL,.02)=SUBSCRPN I $G(XQACOMNT)'="" S @FDA@(8992.112,"+"_NCOUNT_IENVAL,1.01)=XQACOMNT 104 . . . I $G(XQAUSER)>0 S @FDA@(8992.112,"+"_NCOUNT_IENVAL,.03)=XQAUSER 105 . . . Q 106 . . N IENSTR D UPDATE^DIE("",FDA,"IENSTR") 107 . . Q 108 . Q 109 ; 110 I RETVAL S RETVAL=RETVAL_U_$G(XQADA)_U_XQAID 111 K:XQAID'="" ^XTV(8992,"AXQA",XQAID,0,0) 112 K XQA,XQALIN,XQALIN1,XQAMSG,XQAID,XQAFLG,XQAOPT,XQAOPT1,XQAROU,XQADATA,XQI,XQX,XQJ,XQK,XQA1,XQACTMSG,XQJ,XQXI,XQAARCH,XQACNDEL,XQAREVUE,XQASUPV,XQASURO,XQATEXT 113 Q RETVAL 114 ; 115 SNDNACTV(XQAID) ; Determine if we go ahead and send alerts addressed only to inactive users to backup reviewers 116 N XVAL 117 I $E(XQAID,1,3)="TIU" S XVAL=$E($P(XQAID,";"),4,99),XVAL=$$GET1^DIQ(8925,XVAL_",",1201,"I") I XVAL>0,$$FMDIFF^XLFDT(DT,XVAL)>60 Q 0 118 Q 1 119 ; 120 SETIEN(XQA1,XQI) ; determine unique XQAID value for alert 121 N XQAID 122 S:$G(XQA1)="" XQA1="NO-ID" F S XQAID=XQA1_";"_DUZ_";"_XQI L +^XTV(8992,"AXQA",XQAID):10 D L -^XTV(8992,"AXQA",XQAID) Q:XQI="" S XQI=XQI+.00000001 123 . I $D(^XTV(8992,"AXQA",XQAID)) Q 124 . S ^XTV(8992,"AXQA",XQAID,0,0)="",XQI="" 125 . Q 126 Q XQAID 127 ; 128 SETTRACK ; Setup entry in Alert Tracking file 129 ; Note: if there are error messages or we can't create an entry for some reason, it simply returns and continues 130 N FDA,IENS,XQA2,DIERR 131 S XQADA=0 132 S XQA2=XQA1 I XQA2[",",$P(XQA2,",",3)'="" S XQA2=$P(XQA2,",")_","_$P(XQA2,",",3) 133 F D Q:'$D(DIERR) Q:'$D(^TMP("DIERR",$J,"E",111)) 134 . K DIERR,^TMP("DIERR",$J) 135 . S FDA=$NA(^TMP($J,"XQALSET")) K @FDA 136 . S @FDA@(8992.1,"+1,",.01)=XQAID D UPDATE^DIE("",FDA,"IENS") 137 . K @FDA 138 . Q 139 I $D(DIERR) Q ;S XQDIERR1=DIERR M XQDIERR=^TMP("DIERR",$J) Q 140 Q:IENS(1)'>0 S (DA,XQADA)=IENS(1) 141 S IENS=IENS(1)_",",@FDA@(8992.1,IENS,.02)=XQX,^(.03)=XQA2,^(.05)=DUZ,^(1.01)=XQAMSG 142 I $D(XQAARCH) S X=$$FMADD^XLFDT(DT,XQAARCH) I X>DT S @FDA@(8992.1,IENS,.08)=X 143 I $P(XQA1,",")="OR",$P(XQA1,",",2)>0 S @FDA@(8992.1,IENS,.04)=$P(XQA1,",",2) 144 I $D(ZTQUEUED) S @FDA@(8992.1,IENS,.06)=1 145 I $D(XQAOPT)#2 S @FDA@(8992.1,IENS,1.02)=XQAOPT 146 I $D(XQAROU)#2 N XQAXX S XQAXX=$S(XQAROU[U:XQAROU,1:U_XQAROU) I $P(XQAXX,U,2)'="" S:$P(XQAXX,U)'="" @FDA@(8992.1,IENS,1.03)=$P(XQAXX,U) S @FDA@(8992.1,IENS,1.04)=$P(XQAXX,U,2) 147 I $D(XQACTMSG) S @FDA@(8992.1,IENS,1.05)=XQACTMSG 148 I $D(XQADATA) S @FDA@(8992.1,IENS,2)=XQADATA 149 I $D(XQAGUID) S @FDA@(8992.1,IENS,3.01)=XQAGUID 150 I $D(XQADFN) S @FDA@(8992.1,IENS,.04)=XQADFN 151 D FILE^DIE("KS",FDA) 152 I $D(XQATEXT) D WP^DIE(8992.1,IENS,4,"","XQATEXT") 153 Q 154 ; 155 CHEKUSER(XQAUSER) ; .SR Returns 0 if no valid user or surrogate, otherwise returns IEN of user or surrogate 156 Q $$CHEKUSER^XQALSET1(XQAUSER) 157 ; -
WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALSET1.m
r613 r623 1 XQALSET1 ;ISC-SF.SEA/JLI - SETUP ALERTS (OVERFLOW) ;4/9/07 10:26 2 ;;8.0;KERNEL;**285,443**;Jul 10, 1995;Build 4 3 ;; 4 Q 5 GROUP ; 6 N XQI,XQL,XQL1,XQL2,XQLIST 7 S XQL=$E(XQJ,3,$L(XQJ)) ; P443 - changed from code that forced upper case 8 I $D(^TMP("XQAGROUP",$J,XQL)) Q ; P443 group has already been processed - prevent cycling 9 S ^TMP("XQAGROUP",$J,XQL)="" ; P443 mark that the group has been seen 10 S XQI=$$FIND1^DIC(3.8,,"X",XQL) Q:XQI'>0 11 N XQLIST D LIST^DIC(3.81,","_XQI_",",".01","I",,,,,,,.XQLIST) I XQLIST("ORDER")>0 D 12 . N XQI F XQI=0:0 S XQI=$O(@XQLIST@("ID",XQI)) Q:XQI'>0 S XQA(^(XQI,.01))="" 13 . Q 14 K @XQLIST,XQLIST D LIST^DIC(3.811,","_XQI_",",".01",,,,,,,,.XQLIST) I XQLIST("ORDER")>0 D 15 . N XQAGROUP M XQAGROUP=@XQLIST@("ID") ; P443 - store group list data locally so it is not over written by recursive call to LIST^DIC 16 . N XQI F XQI=0:0 S XQI=$O(XQAGROUP(XQI)) Q:XQI'>0 N XQJ S XQJ="G."_XQAGROUP(XQI,.01) D GROUP ; P443 - change to reference XQAGROUP 17 . Q 18 K @XQLIST,XQLIST 19 K XQA(XQJ) 20 D CHEKACTV(.XQA) 21 Q 22 ; 23 ; Check and remove any entries in array that don't have active surrogates and aren't active 24 CHEKACTV(XQARRAY) ; 25 N XQJ 26 F XQJ=0:0 S XQJ=$O(XQARRAY(XQJ)) Q:XQJ'>0 I $$CHEKUSER(XQJ)'>0 K XQARRAY(XQJ) 27 Q 28 ; 29 CHEKUSER(XQAUSER) ; Returns 0 if no valid user or surrogate, otherwise returns IEN of user or surrogate 30 N VALUE 31 S VALUE=$$ACTVSURO^XQALSURO(XQAUSER) 32 I VALUE'>0 S VALUE=XQAUSER I '$$ACTIVE^XUSER(XQAUSER) Q 0 33 Q VALUE 34 ; 1 XQALSET1 ;ISC-SF.SEA/JLI - SETUP ALERTS (OVERFLOW) ;10/20/03 15:03 2 ;;8.0;KERNEL;**285**;Jul 10, 1995 3 ;; 4 Q 5 GROUP ; 6 N XQI,XQL,XQL1,XQL2,XQLIST 7 S XQL="" F XQI=3:1:$L(XQJ) S XQL1=$E(XQJ,XQI) S:XQL1?1L XQL1=$C($A(XQL1)-32) S XQL=XQL_XQL1 8 ;S XQI=$O(^XMB(3.8,"B",XQL,0)) I XQI'>0 S XQL1=$O(^XMB(3.8,"B",XQL)) I $E(XQL1,1,$L(XQL))=XQL S XQL2=$O(^(XQL1)) I $E(XQL2,1,$L(XQL))'=XQL S XQI=$O(^(XQL1,0)) 9 ;I XQI>0 F XQL=0:0 S XQL=$O(^XMB(3.8,XQI,1,XQL)) Q:XQL'>0 S XQA(+^(XQL,0))="" 10 ; Above code replaced to use Fileman calls, also code added to walk through member groups as well 030203 JLI P285 11 S XQI=$$FIND1^DIC(3.8,,"X",XQL) Q:XQI'>0 12 N XQLIST D LIST^DIC(3.81,","_XQI_",",".01","I",,,,,,,.XQLIST) I XQLIST("ORDER")>0 D 13 . N XQI F XQI=0:0 S XQI=$O(@XQLIST@("ID",XQI)) Q:XQI'>0 S XQA(^(XQI,.01))="" 14 . Q 15 K @XQLIST,XQLIST D LIST^DIC(3.811,","_XQI_",",".01",,,,,,,,.XQLIST) I XQLIST("ORDER")>0 D 16 . N XQI F XQI=0:0 S XQI=$O(@XQLIST@("ID",XQI)) Q:XQI'>0 N XQJ S XQJ="G."_^(XQI,.01) D GROUP 17 . Q 18 K XQA(XQJ) 19 D CHEKACTV(.XQA) 20 Q 21 ; 22 ; Check and remove any entries in array that don't have active surrogates and aren't active 23 CHEKACTV(XQARRAY) ; 24 N XQJ 25 F XQJ=0:0 S XQJ=$O(XQARRAY(XQJ)) Q:XQJ'>0 I $$CHEKUSER(XQJ)'>0 K XQARRAY(XQJ) 26 Q 27 ; 28 CHEKUSER(XQAUSER) ;SR. Returns 0 if no valid user or surrogate, otherwise returns IEN of user or surrogate 29 N VALUE 30 S VALUE=$$ACTVSURO^XQALSURO(XQAUSER) 31 I VALUE'>0 S VALUE=XQAUSER I '$$ACTIVE^XUSER(XQAUSER) Q 0 32 Q VALUE 33 ; -
WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALSUR1.m
r613 r623 1 XQALSUR1 ;ISC-SF.SEA/JLI - SURROGATES FOR ALERTS ;11/21/07 08:35 2 ;;8.0;KERNEL;**366,443**;Jul 10, 1995;Build 4 3 Q 4 ; 5 RETURN(XQAUSER) ; P366 - return alerts to the user 6 N XQAI,X0,XQASTRT,XQASURO,XQAEND 7 ; identify periods in the surrogate multiple that haven't been returned 8 F XQAI=0:0 S XQAI=$O(^XTV(8992,XQAUSER,2,"AC",1,XQAI)) Q:XQAI'>0 S X0=^XTV(8992,XQAUSER,2,XQAI,0) I $P(X0,U,4)=1 D 9 . S XQASTRT=$P(X0,U) S XQAEND=$P(X0,U,3) 10 . ; and clear the flag indicating we need to restore these alerts 11 . N XQAFDA S XQAFDA(8992.02,XQAI_","_XQAUSER_",",.04)="@" D FILE^DIE("","XQAFDA") 12 . ; restore alerts to intended user, remove from surrogate if completed (i.e., no other surrogates and not intended recipient) 13 . D PUSHBACK(XQAUSER,XQASTRT,XQAEND) 14 . Q 15 Q 16 ; 17 PUSHBACK(XQAUSER,XQASTRT,XQAEND) ; P366 - identify alerts in alert tracking file for return and return them 18 N XQAINIT,XQAI,X0,X30,XNOSURO,XQADT,XQAJ,XQAK,XQAL,XQAOTH,XQASUROP 19 S XQAINIT=$$FIND1^DIC(8992.2,,"X","INITIAL RECIPIENT") 20 F XQADT=XQASTRT-.0000001:0 S XQADT=$O(^XTV(8992.1,"AUD",XQAUSER,XQADT)) Q:XQADT'>0 Q:XQADT>XQAEND F XQAI=0:0 S XQAI=$O(^XTV(8992.1,"AUD",XQAUSER,XQADT,XQAI)) Q:XQAI'>0 D 21 . S XQAJ=$O(^XTV(8992.1,XQAI,20,"B",XQAUSER,0)) Q:XQAJ'>0 22 . N XSURO,XNOSURO,XQAID S XNOSURO=0,XQAID=$P(^XTV(8992.1,XQAI,0),U) 23 . F XQAK=0:0 S XQAK=$O(^XTV(8992.1,XQAI,20,XQAJ,1,"B",XQAK)) Q:XQAK'>0 F XQAL=0:0 S XQAL=$O(^XTV(8992.1,XQAI,20,XQAJ,1,"B",XQAK,XQAL)) Q:XQAL'>0 D 24 . . S X0=^XTV(8992.1,XQAI,20,XQAJ,1,XQAL,0) S:$P(X0,U,2)>0 XSURO($P(X0,U,2))="" S:$P(X0,U,2)'>0 XNOSURO=1 ; sent to XSURO as surrogate 25 . . Q 26 . I 'XNOSURO D 27 . . N XQA,XQACMNT,XQALTYPE 28 . . S XQA(XQAUSER)="",XQACMNT="RESTORED FROM SURROGATE",XQALTYPE="RESTORE FROM SURROGATE" 29 . . N XQAUSER,XQAI S XQAUSER=$O(^XTV(8992,"AXQA",XQAID,0)) Q:XQAUSER'>0 D RESETUP^XQALFWD(XQAID,.XQA,XQACMNT) 30 . . Q 31 . ; walk through each of those it was sent to as a surrogate for XQAUSER 32 . F XQASUROP=0:0 S XQASUROP=$O(XSURO(XQASUROP)) Q:XQASUROP'>0 S XQAJ=$O(^XTV(8992.1,XQAI,20,"B",XQASUROP,0)) D 33 . . ; and identify each time they were considered a recipient of the alert 34 . . S XNOSURO=0 F XQAK=0:0 Q:XNOSURO S XQAK=$O(^XTV(8992.1,XQAI,20,XQAJ,1,"B",XQAK)) Q:XQAK'>0 F XQAL=0:0 S XQAL=$O(^XTV(8992.1,XQAI,20,XQAJ,1,"B",XQAK,XQAL)) Q:XQAL'>0 S X0=^XTV(8992.1,XQAI,20,XQAJ,1,XQAL,0) D Q:XNOSURO 35 . . . I $P(X0,U,3)'="Y" S XNOSURO=1 Q ; this one got it directly as a recipient as well 36 . . . ; walk through the SURROGATE FOR entries for this user 37 . . . F XQAOTH=0:0 S XQAOTH=$O(^XTV(8992.1,XQAI,20,XQAJ,3,XQAOTH)) Q:XQAOTH'>0 S X30=^(XQAOTH,0) D Q:XNOSURO 38 . . . . I +X30=XQAUSER S $P(^XTV(8992.1,XQAI,20,XQAJ,3,XQAOTH,0),U,3)=$$NOW^XLFDT() Q ; mark this user as returned 39 . . . . I $P(X30,U,3)'>0 S XNOSURO=1 Q ; another surrogate hasn't been returned yet, so leave the alert 40 . . . . Q 41 . . . Q 42 . . I 'XNOSURO D 43 . . . N XQAKILL,XQAUSER,XQAI S XQAKILL=1,XQAUSER=XQASUROP D DELETE^XQALDEL 44 . . . Q 45 . . Q 46 . Q 47 Q 48 ; 49 SUROLIST(XQAUSER,XQALIST) ; returns for XQAUSER a list of current and/or future surrogates in XQALIST 50 ; usage D SUROLIST^XQALSUR1(DUZ,.XQALIST) 51 ; 52 ; returns XQALIST=count 53 ; XQALIST(1)=IEN2^NEWPERSON,USER2^STARTDATETIME^ENDDATETIME 54 ; XQALIST(2)=3^NAME,USER3^3050407.1227^3050406 55 ; 56 N XQA0,XQADATE,XQAIEN,XQAL,XQALCNT,XQALEND,XQANOW,XQASTART,XQASURO,XQAVALU 57 D CHEKSUBS^XQALSUR2(XQAUSER) 58 S XQALCNT=$$CURRSURO^XQALSURO(XQAUSER) 59 S XQANOW=$$NOW^XLFDT(),XQALCNT=0 60 S XQADATE="" F S XQADATE=$O(^XTV(8992,XQAUSER,2,"B",XQADATE)) Q:XQADATE'>0 S XQAIEN="" F S XQAIEN=$O(^XTV(8992,XQAUSER,2,"B",XQADATE,XQAIEN)) Q:XQAIEN'>0 D 61 . S XQA0=^XTV(8992,XQAUSER,2,XQAIEN,0),XQASTART=$P(XQA0,U),XQASURO=$P(XQA0,U,2),XQALEND=$P(XQA0,U,3) I XQALEND>0,XQALEND'>XQANOW Q 62 . S XQALCNT=XQALCNT+1,XQAVALU=$$GET1^DIQ(200,XQASURO_",",.01),XQAL(XQALCNT)=XQASURO_U_XQAVALU_U_XQASTART_U_XQALEND 63 . Q 64 ; now rearrange by earliest to last 65 K XQALIST S XQALIST=0 66 S XQALCNT="" F S XQALCNT=$O(XQAL(XQALCNT)) Q:XQALCNT'>0 D 67 . ; if end date not specified, and start date follows, set end date to next start date 68 . I $D(XQAL(XQALCNT+1)),($P(XQAL(XQALCNT),U,4)>$P(XQAL(XQALCNT+1),U,3))!($P(XQAL(XQALCNT),U,4)'>0) S $P(XQAL(XQALCNT),U,4)=$P(XQAL(XQALCNT+1),U,3) 69 . S XQALIST=XQALIST+1,XQALIST(XQALIST)=XQAL(XQALCNT) 70 . Q 71 Q 72 ; 73 DCYCLIC(XQALSURO,XQAUSER,XQALSTRT,XQALEND) ; code added to prevent cyclical surrogates - use dates for surrogacy 74 N XQALNEXT,XQALIST,I,XQALAST 75 I XQALSURO=XQAUSER Q "This forms a circle which leads back to this user during this period - can't do it!" 76 S XQALNEXT=$$CURRSURO^XQALSURO(XQALSURO,XQALSTRT,XQALEND) I XQALNEXT>0 D 77 . F I=1:1 Q:$P(XQALNEXT,U,I)="" S XQALAST=$$DCYCLIC($P(XQALNEXT,U,I),XQAUSER,XQALSTRT,XQALEND) I XQALAST'>0 S XQALSURO=XQALAST Q 78 . Q 79 Q XQALSURO 80 ; 81 DATESURO(XQAUSER,XQALSTRT,XQALEND) ; returns surrogate(s) for XQAUSER in date range XQALSTRT to XQALEND, may be multiple values ^-separated 82 N XQALY,XQA0,XQALIEN,XQALS 83 S XQALY="" I XQALEND'>0 S XQALEND=4000101 84 F XQALS=0:0 S XQALS=$O(^XTV(8992,XQAUSER,2,"B",XQALS)) Q:XQALS'>0 Q:XQALS'<XQALEND D 85 . F XQALIEN=0:0 S XQALIEN=$O(^XTV(8992,XQAUSER,2,"B",XQALS,XQALIEN)) Q:XQALIEN'>0 S XQA0=^XTV(8992,XQAUSER,2,XQALIEN,0) Q:$P(XQA0,U,3)'>XQALSTRT S XQALY=XQALY_$S(XQALY="":"",1:U)_$P(XQA0,U,2) 86 . Q 87 Q XQALY 88 ; 89 SURRO1(XQAUSER) ; 90 N XQALSURO,XQALSTRT,XQALEND 91 D CHKREMV^XQALSURO 92 SURRO11 ; 93 S XQALSURO=$$NEWDLG() I XQALSURO'>0 Q 94 I $$CYCLIC^XQALSURO(XQALSURO,XQAUSER)'>0 W $C(7),!,$$CYCLIC^XQALSURO(XQALSURO,XQAUSER),! G SURRO11 95 S XQALSTRT=+$$STRTDLG() I XQALSTRT<0 Q 96 S XQALEND=+$$ENDDLG() I XQALEND<0 Q 97 D SETSURO^XQALSURO(XQAUSER,XQALSURO,XQALSTRT,XQALEND) 98 G SURRO11 ; 99 Q 100 ; 101 ; P366 - added OPTIONAL second and third arguments to permit deletion of a specific pending surrogate and start date 102 REMVSURO(XQAUSER,XQALSURO,XQALSTRT) ; SR - ends the currently active surrogate relationship 103 I $G(XQAUSER)'>0 Q 104 S XQALSURO=$G(XQALSURO),XQALSTRT=$G(XQALSTRT) 105 N XQALFM,XQALXREF,XQALSTR1,XQALSUR1,XQALNOW,XQALEND,XQA0 106 D CHEKSUBS^XQALSUR2(XQAUSER) 107 S XQALSUR1=+$P($G(^XTV(8992,XQAUSER,0)),U,2) S:XQALSURO'>0 XQALSURO=XQALSUR1 108 S XQALSTR1=$P($G(^XTV(8992,XQAUSER,0)),U,3) S:XQALSTRT'>0 XQALSTRT=XQALSTR1 109 S XQALEND=$P($G(^XTV(8992,XQAUSER,0)),U,4) 110 S XQALXREF=0 I XQALSTRT>0 F S XQALXREF=$O(^XTV(8992,XQAUSER,2,"B",XQALSTRT,XQALXREF)) Q:XQALXREF'>0 I $P(^XTV(8992,XQAUSER,2,XQALXREF,0),U,2)=XQALSURO D 111 . S XQALEND=$P(^XTV(8992,XQAUSER,2,XQALXREF,0),U,3) D DELETENT(XQAUSER,XQALXREF,XQALSURO,XQALSTRT,XQALSUR1,XQALSTR1,XQALEND) 112 . Q 113 S XQALSURO=$$CURRSURO^XQALSURO(XQAUSER) ; make sure current surrogate is updated if necessary. 114 Q 115 ; 116 DELETENT(XQAUSER,XQALXREF,XQALSURO,XQALSTRT,XQALSUR1,XQALSTR1,XQALEND) ; 117 N XQALNOW,XQALFM 118 S XQAUSER=XQAUSER_",",XQALXREF=XQALXREF_","_XQAUSER 119 I XQALXREF>0 D 120 . S XQALNOW=$$NOW^XLFDT() 121 . I XQALSTRT>XQALNOW S XQALFM(8992.02,XQALXREF,.01)=XQALNOW ; if scheduled for later, mark start as now 122 . I (XQALEND>XQALNOW)!(XQALEND'>0) S XQALFM(8992.02,XQALXREF,.03)=XQALNOW ; update end time for surrogate to now 123 . I XQALSTRT'>XQALNOW S XQALFM(8992.02,XQALXREF,.04)=1 124 . Q 125 I XQALSUR1=XQALSURO,XQALSTRT=XQALSTR1 D 126 . S XQALFM(8992,XQAUSER,.02)="@" 127 . S XQALFM(8992,XQAUSER,.03)="@" 128 . S XQALFM(8992,XQAUSER,.04)="@" 129 . Q 130 I $D(XQALFM) D FILE^DIE("","XQALFM") 131 ; ZEXCEPT: XTMUNIT (EXTERNAL VALUE - INDICATING UNIT TEST BEING RUN) 132 I XQALSURO>0,'$D(XTMUNIT) D 133 . N XQAMESG,XMSUB,XMTEXT 134 . S XQAMESG(1,0)="You have been REMOVED as a surrogate recipient for alerts for" 135 . S XQAMESG(2,0)=$$GET1^DIQ(200,XQAUSER,.01,"E")_" (IEN="_$P(XQAUSER,",")_")." 136 . S XMTEXT="XQAMESG(",XMSUB="Removal as surrogate recipient" 137 . D SENDMESG^XQALSURO 138 . Q 139 Q 140 ; 141 NEWDLG() ; new surrogate dialog 142 N DIR,Y S DIR(0)="Y",DIR("A")="Do you want to SET a new surrogate recipient",DIR("?")="A surrogate will receive your alerts until they are removed as surrogate.",DIR("B")="NO" 143 S Y=$$ASKDIR(.DIR) I 'Y Q 0 144 ; 145 S DIR(0)="P^200:AEMQ",DIR("A")="Select USER to be SURROGATE" S Y=$$ASKDIR(.DIR) ; COS-0401-41366 146 I Y>0 W " ",$P(Y,U,2) 147 Q +Y 148 ; 149 STRTDLG() ; new surrogate start date/time dialog 150 N DIR 151 S DIR(0)="DO^::ATEX",DIR("A")="Specify Date/Time SURROGATE becomes active" ; BRX-1000-10427 152 S DIR("A",1)="",DIR("A",2)="" 153 S DIR("A",3)="if no date/time is entered, alerts will start going to" 154 S DIR("A",4)="the SURROGATE immediately." 155 Q +$$ASKDIR(.DIR) 156 ; 157 ENDDLG() ; new surrogate end date/time dialog 158 N DIR 159 S DIR(0)="DO^::AETX",DIR("A")="Specify Date/Time SURROGATE should be removed" ; BRX-1000-10427 160 S DIR("A",1)="",DIR("A",2)="" 161 S DIR("A",3)="if no date/time is entered, YOU must remove the SURROGATE" 162 S DIR("A",4)="to terminate alerts going to the SURROGATE" 163 Q +$$ASKDIR(.DIR) 164 ; 165 ASKDIR(DIR) ; 166 N Y,DTOUT,DUOUT 167 D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S Y=-1 168 Q Y 1 XQALSUR1 ;ISC-SF.SEA/JLI - SURROGATES FOR ALERTS ;9/6/05 14:26 2 ;;8.0;KERNEL;**366**;Jul 10, 1995 3 Q 4 ; 5 RETURN(XQAUSER) ; P366 - return alerts to the user 6 N XQAI,X0,XQASTRT,XQASURO,XQAEND 7 ; identify periods in the surrogate multiple that haven't been returned 8 F XQAI=0:0 S XQAI=$O(^XTV(8992,XQAUSER,2,"AC",1,XQAI)) Q:XQAI'>0 S X0=^XTV(8992,XQAUSER,2,XQAI,0) I $P(X0,U,4)=1 D 9 . S XQASTRT=$P(X0,U) S XQAEND=$P(X0,U,3) 10 . ; and clear the flag indicating we need to restore these alerts 11 . N XQAFDA S XQAFDA(8992.02,XQAI_","_XQAUSER_",",.04)="@" D FILE^DIE("","XQAFDA") 12 . ; restore alerts to intended user, remove from surrogate if completed (i.e., no other surrogates and not intended recipient) 13 . D PUSHBACK(XQAUSER,XQASTRT,XQAEND) 14 . Q 15 Q 16 ; 17 PUSHBACK(XQAUSER,XQASTRT,XQAEND) ; P366 - identify alerts in alert tracking file for return and return them 18 N XQAINIT,XQAI,X0,X30,XNOSURO,XQADT,XQAJ,XQAK,XQAL,XQAOTH,XQASUROP 19 S XQAINIT=$$FIND1^DIC(8992.2,,"X","INITIAL RECIPIENT") 20 F XQADT=XQASTRT-.0000001:0 S XQADT=$O(^XTV(8992.1,"AUD",XQAUSER,XQADT)) Q:XQADT'>0 Q:XQADT>XQAEND F XQAI=0:0 S XQAI=$O(^XTV(8992.1,"AUD",XQAUSER,XQADT,XQAI)) Q:XQAI'>0 D 21 . S XQAJ=$O(^XTV(8992.1,XQAI,20,"B",XQAUSER,0)) Q:XQAJ'>0 22 . N XSURO,XNOSURO,XQAID S XNOSURO=0,XQAID=$P(^XTV(8992.1,XQAI,0),U) 23 . F XQAK=0:0 S XQAK=$O(^XTV(8992.1,XQAI,20,XQAJ,1,"B",XQAK)) Q:XQAK'>0 F XQAL=0:0 S XQAL=$O(^XTV(8992.1,XQAI,20,XQAJ,1,"B",XQAK,XQAL)) Q:XQAL'>0 D 24 . . S X0=^XTV(8992.1,XQAI,20,XQAJ,1,XQAL,0) S:$P(X0,U,2)>0 XSURO($P(X0,U,2))="" S:$P(X0,U,2)'>0 XNOSURO=1 ; sent to XSURO as surrogate 25 . . Q 26 . I 'XNOSURO D 27 . . N XQA,XQACMNT,XQALTYPE 28 . . S XQA(XQAUSER)="",XQACMNT="RESTORED FROM SURROGATE",XQALTYPE="RESTORE FROM SURROGATE" 29 . . N XQAUSER,XQAI S XQAUSER=$O(^XTV(8992,"AXQA",XQAID,0)) Q:XQAUSER'>0 D RESETUP^XQALFWD(XQAID,.XQA,XQACMNT) 30 . . Q 31 . ; walk through each of those it was sent to as a surrogate for XQAUSER 32 . F XQASUROP=0:0 S XQASUROP=$O(XSURO(XQASUROP)) Q:XQASUROP'>0 S XQAJ=$O(^XTV(8992.1,XQAI,20,"B",XQASUROP,0)) D 33 . . ; and identify each time they were considered a recipient of the alert 34 . . S XNOSURO=0 F XQAK=0:0 Q:XNOSURO S XQAK=$O(^XTV(8992.1,XQAI,20,XQAJ,1,"B",XQAK)) Q:XQAK'>0 F XQAL=0:0 S XQAL=$O(^XTV(8992.1,XQAI,20,XQAJ,1,"B",XQAK,XQAL)) Q:XQAL'>0 S X0=^XTV(8992.1,XQAI,20,XQAJ,1,XQAL,0) D Q:XNOSURO 35 . . . I $P(X0,U,3)'="Y" S XNOSURO=1 Q ; this one got it directly as a recipient as well 36 . . . ; walk through the SURROGATE FOR entries for this user 37 . . . F XQAOTH=0:0 S XQAOTH=$O(^XTV(8992.1,XQAI,20,XQAJ,3,XQAOTH)) Q:XQAOTH'>0 S X30=^(XQAOTH,0) D Q:XNOSURO 38 . . . . I +X30=XQAUSER S $P(^XTV(8992.1,XQAI,20,XQAJ,3,XQAOTH,0),U,3)=$$NOW^XLFDT() Q ; mark this user as returned 39 . . . . I $P(X30,U,3)'>0 S XNOSURO=1 Q ; another surrogate hasn't been returned yet, so leave the alert 40 . . . . Q 41 . . . Q 42 . . I 'XNOSURO D 43 . . . N XQAKILL,XQAUSER,XQAI S XQAKILL=1,XQAUSER=XQASUROP D DELETE^XQALDEL 44 . . . Q 45 . . Q 46 . Q 47 Q 48 ; 49 SUROLIST(XQAUSER,XQALIST) ; returns for XQAUSER a list of current and/or future surrogates in XQALIST 50 ; usage D SUROLIST^XQALSUR1(DUZ,.XQALIST) 51 ; 52 ; returns XQALIST=count 53 ; XQALIST(1)=IEN2^NEWPERSON,USER2^STARTDATETIME^ENDDATETIME 54 ; XQALIST(2)=3^NAME,USER3^3050407.1227^3050406 55 ; 56 N XQA0,XQADATE,XQAIEN,XQAL,XQALCNT,XQALEND,XQANOW,XQASTART,XQASURO,XQAVALU 57 D CHEKSUBS^XQALSUR2(XQAUSER) 58 S XQALCNT=$$CURRSURO^XQALSURO(XQAUSER) 59 S XQANOW=$$NOW^XLFDT(),XQALCNT=0 60 S XQADATE="" F S XQADATE=$O(^XTV(8992,XQAUSER,2,"B",XQADATE)) Q:XQADATE'>0 S XQAIEN="" F S XQAIEN=$O(^XTV(8992,XQAUSER,2,"B",XQADATE,XQAIEN)) Q:XQAIEN'>0 D 61 . S XQA0=^XTV(8992,XQAUSER,2,XQAIEN,0),XQASTART=$P(XQA0,U),XQASURO=$P(XQA0,U,2),XQALEND=$P(XQA0,U,3) I XQALEND>0,XQALEND'>XQANOW Q 62 . S XQALCNT=XQALCNT+1,XQAVALU=$$GET1^DIQ(200,XQASURO_",",.01),XQAL(XQALCNT)=XQASURO_U_XQAVALU_U_XQASTART_U_XQALEND 63 . Q 64 ; now rearrange by earliest to last 65 K XQALIST S XQALIST=0 66 S XQALCNT="" F S XQALCNT=$O(XQAL(XQALCNT)) Q:XQALCNT'>0 D 67 . ; if end date not specified, and start date follows, set end date to next start date 68 . I $D(XQAL(XQALCNT+1)),($P(XQAL(XQALCNT),U,4)>$P(XQAL(XQALCNT+1),U,3))!($P(XQAL(XQALCNT),U,4)'>0) S $P(XQAL(XQALCNT),U,4)=$P(XQAL(XQALCNT+1),U,3) 69 . S XQALIST=XQALIST+1,XQALIST(XQALIST)=XQAL(XQALCNT) 70 . Q 71 Q 72 ; 73 DCYCLIC(XQALSURO,XQAUSER,XQALSTRT,XQALEND) ; code added to prevent cyclical surrogates - use dates for surrogacy 74 N XQALNEXT,XQALIST,I,XQALAST 75 I XQALSURO=XQAUSER Q "This forms a circle which leads back to this user during this period - can't do it!" 76 S XQALNEXT=$$CURRSURO^XQALSURO(XQALSURO,XQALSTRT,XQALEND) I XQALNEXT>0 D 77 . F I=1:1 Q:$P(XQALNEXT,U,I)="" S XQALAST=$$DCYCLIC($P(XQALNEXT,U,I),XQAUSER,XQALSTRT,XQALEND) I XQALAST'>0 S XQALSURO=XQALAST Q 78 . Q 79 Q XQALSURO 80 ; 81 DATESURO(XQAUSER,XQALSTRT,XQALEND) ; returns surrogate(s) for XQAUSER in date range XQALSTRT to XQALEND, may be multiple values ^-separated 82 N XQALY,XQA0,XQALIEN,XQALS 83 S XQALY="" I XQALEND'>0 S XQALEND=4000101 84 F XQALS=0:0 S XQALS=$O(^XTV(8992,XQAUSER,2,"B",XQALS)) Q:XQALS'>0 Q:XQALS'<XQALEND D 85 . F XQALIEN=0:0 S XQALIEN=$O(^XTV(8992,XQAUSER,2,"B",XQALS,XQALIEN)) Q:XQALIEN'>0 S XQA0=^XTV(8992,XQAUSER,2,XQALIEN,0) Q:$P(XQA0,U,3)'>XQALSTRT S XQALY=XQALY_$S(XQALY="":"",1:U)_$P(XQA0,U,2) 86 . Q 87 Q XQALY 88 ; 89 SURRO1(XQAUSER) ; 90 N XQALSURO,XQALSTRT,XQALEND 91 D CHKREMV^XQALSURO 92 SURRO11 ; 93 S XQALSURO=$$NEWDLG() I XQALSURO'>0 Q 94 I $$CYCLIC^XQALSURO(XQALSURO,XQAUSER)'>0 W $C(7),!,$$CYCLIC^XQALSURO(XQALSURO,XQAUSER),! G SURRO1 95 S XQALSTRT=+$$STRTDLG() I XQALSTRT<0 Q 96 S XQALEND=+$$ENDDLG() I XQALEND<0 Q 97 D SETSURO^XQALSURO(XQAUSER,XQALSURO,XQALSTRT,XQALEND) 98 G SURRO11 ; 99 Q 100 ; 101 ; P366 - added OPTIONAL second and third arguments to permit deletion of a specific pending surrogate and start date 102 REMVSURO(XQAUSER,XQALSURO,XQALSTRT) ; SR - ends the currently active surrogate relationship 103 I $G(XQAUSER)'>0 Q 104 S XQALSURO=$G(XQALSURO),XQALSTRT=$G(XQALSTRT) 105 N XQALFM,XQALXREF,XQALSTR1,XQALSUR1,XQALNOW,XQALEND,XQA0 106 ; ZEXCEPT: XQATEST (EXTERNAL VALUE - INDICATING TEST BEING RUN) 107 D CHEKSUBS^XQALSUR2(XQAUSER) 108 S XQALSUR1=+$P($G(^XTV(8992,XQAUSER,0)),U,2) S:XQALSURO'>0 XQALSURO=XQALSUR1 109 S XQALSTR1=$P($G(^XTV(8992,XQAUSER,0)),U,3) S:XQALSTRT'>0 XQALSTRT=XQALSTR1 110 S XQALEND=$P($G(^XTV(8992,XQAUSER,0)),U,4) 111 S XQALXREF=0 I XQALSTRT>0 F S XQALXREF=$O(^XTV(8992,XQAUSER,2,"B",XQALSTRT,XQALXREF)) Q:XQALXREF'>0 I $P(^XTV(8992,XQAUSER,2,XQALXREF,0),U,2)=XQALSURO D 112 . S XQALEND=$P(^XTV(8992,XQAUSER,2,XQALXREF,0),U,3) D DELETENT(XQAUSER,XQALXREF,XQALSURO,XQALSTRT,XQALSUR1,XQALSTR1,XQALEND) 113 . Q 114 S XQALSURO=$$CURRSURO^XQALSURO(XQAUSER) ; make sure current surrogate is updated if necessary. 115 Q 116 ; 117 DELETENT(XQAUSER,XQALXREF,XQALSURO,XQALSTRT,XQALSUR1,XQALSTR1,XQALEND) ; 118 N XQALNOW,XQALFM 119 ; ZEXCEPT: XQATEST (EXTERNAL VALUE - INDICATING TEST BEING RUN) 120 S XQAUSER=XQAUSER_",",XQALXREF=XQALXREF_","_XQAUSER 121 I XQALXREF>0 D 122 . S XQALNOW=$$NOW^XLFDT() 123 . I XQALSTRT>XQALNOW S XQALFM(8992.02,XQALXREF,.01)=XQALNOW ; if scheduled for later, mark start as now 124 . I (XQALEND>XQALNOW)!(XQALEND'>0) S XQALFM(8992.02,XQALXREF,.03)=XQALNOW ; update end time for surrogate to now 125 . I XQALSTRT'>XQALNOW S XQALFM(8992.02,XQALXREF,.04)=1 126 . Q 127 I XQALSUR1=XQALSURO,XQALSTRT=XQALSTR1 D 128 . S XQALFM(8992,XQAUSER,.02)="@" 129 . S XQALFM(8992,XQAUSER,.03)="@" 130 . S XQALFM(8992,XQAUSER,.04)="@" 131 . Q 132 I $D(XQALFM) D FILE^DIE("","XQALFM") 133 I XQALSURO>0,'$D(XQATEST) D 134 . N XQAMESG,XMSUB,XMTEXT 135 . S XQAMESG(1,0)="You have been REMOVED as a surrogate recipient for alerts for" 136 . S XQAMESG(2,0)=$$GET1^DIQ(200,XQAUSER,.01,"E")_" (IEN="_$P(XQAUSER,",")_")." 137 . S XMTEXT="XQAMESG(",XMSUB="Removal as surrogate recipient" 138 . D SENDMESG^XQALSURO 139 . Q 140 Q 141 ; 142 NEWDLG() ; new surrogate dialog 143 N DIR,Y S DIR(0)="Y",DIR("A")="Do you want to SET a new surrogate recipient",DIR("?")="A surrogate will receive your alerts until they are removed as surrogate.",DIR("B")="NO" 144 S Y=$$ASKDIR(.DIR) I 'Y Q 0 145 ; 146 S DIR(0)="P^200:AEMQ",DIR("A")="Select USER to be SURROGATE" S Y=$$ASKDIR(.DIR) ; COS-0401-41366 147 I Y>0 W " ",$P(Y,U,2) 148 Q +Y 149 ; 150 STRTDLG() ; new surrogate start date/time dialog 151 N DIR 152 S DIR(0)="DO^::ATEX",DIR("A")="Specify Date/Time SURROGATE becomes active" ; BRX-1000-10427 153 S DIR("A",1)="",DIR("A",2)="" 154 S DIR("A",3)="if no date/time is entered, alerts will start going to" 155 S DIR("A",4)="the SURROGATE immediately." 156 Q +$$ASKDIR(.DIR) 157 ; 158 ENDDLG() ; new surrogate end date/time dialog 159 N DIR 160 S DIR(0)="DO^::AETX",DIR("A")="Specify Date/Time SURROGATE should be removed" ; BRX-1000-10427 161 S DIR("A",1)="",DIR("A",2)="" 162 S DIR("A",3)="if no date/time is entered, YOU must remove the SURROGATE" 163 S DIR("A",4)="to terminate alerts going to the SURROGATE" 164 Q +$$ASKDIR(.DIR) 165 ; 166 ASKDIR(DIR) ; 167 N Y,DTOUT,DUOUT 168 D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S Y=-1 169 Q Y -
WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALSURO.m
r613 r623 1 XQALSURO ;ISC-SF.SEA/JLI - SURROGATES FOR ALERTS ;3/17/08 15:20 2 ;;8.0;KERNEL;**114,125,173,285,366,443**;Jul 10, 1995;Build 4 3 ;; 4 Q 5 OTHRSURO ; OPT:- XQALERT SURROGATE SET/REMOVE -- OTHERS SPECIFY SURROGATE FOR SELECTED USER 6 N XQAUSER,DIR,Y 7 S DIR(0)="PD^200:AEMQ",DIR("A",1)="SURROGATE related to which" 8 S DIR("A")="NEW PERSON entry" 9 D ^DIR K DIR Q:Y'>0 W " ",$P(Y,U,2) 10 S XQAUSER=+Y 11 G SURROGAT 12 Q 13 ; 14 SURROGAT ; USER SPECIFICATION OF SURROGATE 15 I '$D(XQAUSER) N XQAUSER S XQAUSER=DUZ 16 D SURRO1^XQALSUR1(XQAUSER) 17 Q 18 CYCLIC(XQALSURO,XQAUSER,XQASTRT,XQAEND) ; code added to prevent cyclical surrogates 19 I '$$ACTIVE^XUSER(XQALSURO) Q "You cannot have an INACTIVE USER ("_XQALSURO_") as a surrogate!" ;P443 20 I XQALSURO=XQAUSER Q "You cannot specify yourself as your own surrogate!" ; moved in P443 21 I $G(XQASTRT)>0 Q $$DCYCLIC^XQALSUR1(XQALSURO,XQAUSER,XQASTRT,$G(XQAEND)) 22 N XQALSTRT 23 S XQALSTRT=$$CURRSURO(XQALSURO) I XQALSTRT>0 D 24 . I XQALSTRT=XQAUSER S XQALSURO="YOU are designated as the surrogate for this user ("_XQALSURO_") - can't do it!" Q 25 . F S XQALSTRT=$$CURRSURO(XQALSTRT) Q:XQALSTRT'>0 I XQALSTRT=XQAUSER S XQALSURO="This forms a circle which leads back to you - can't do it!" Q 26 . Q 27 Q XQALSURO 28 ; 29 SETSURO(XQAUSER,XQALSURO,XQALSTRT,XQALEND) ; Use SETSURO1 instead 30 N XQALVAL ; P443 31 S XQALVAL=$$SETSURO1(XQAUSER,XQALSURO,$G(XQALSTRT),$G(XQALEND)) ; P443 32 Q 33 ; 34 SETSUROX(XQAUSER,XQALSURO,XQALSTRT,XQALEND) ; SETSURO CODE MOVED TO HERE TO PERMIT AN ERROR TO BE GENERATED AT THE OLD ENTRY POINT 35 N XQALFM,XQALIEN,XQAIENS 36 I $G(XQAUSER)'>0 Q 37 I $G(XQALSURO)'>0 Q 38 I '$D(^XTV(8992,XQAUSER,0)) D 39 . N XQALFM,XQALFM1 40 . S XQALFM1(1)=XQAUSER 41 . S XQALFM(8992,"+1,",.01)=XQAUSER 42 . D UPDATE^DIE("","XQALFM","XQALFM1") 43 . Q 44 S XQAIENS=XQAUSER_"," 45 ; P366 - force no start date/time to NOW 46 ; P366 - change to force anything less than NOW to NOW - 8/22/05 47 I $G(XQALSTRT)<$$NOW^XLFDT() S XQALSTRT=$$NOW^XLFDT() 48 ; P366 - add values to new multiple 49 S XQALFM(8992.02,"+1,"_XQAIENS,.01)=XQALSTRT 50 S XQALFM(8992.02,"+1,"_XQAIENS,.02)=XQALSURO 51 I XQALEND>0 S XQALFM(8992.02,"+1,"_XQAIENS,.03)=XQALEND 52 K XQALIEN D UPDATE^DIE("","XQALFM","XQALIEN") 53 ; P366 - if start date time is already in effect - place in old locations to make active 54 I XQALSTRT'>$$NOW^XLFDT() D ACTIVATE(XQAUSER,XQALIEN(1)) 55 N XQAMESG,XMSUB,XMTEXT 56 S XQAMESG(1,0)="You have been specified as a surrogate recipient for alerts for" 57 S XQAMESG(2,0)=$$GET1^DIQ(200,XQAIENS,.01,"E")_" (IEN="_XQAUSER_") effective "_$$FMTE^XLFDT(XQALSTRT) 58 I $G(XQALEND)'>0 S XQAMESG(2,0)=XQAMESG(2,0)_"." 59 E S XQAMESG(3,0)="until "_$$FMTE^XLFDT(XQALEND) 60 S XMSUB="Surrogate Recipient for "_$$GET1^DIQ(200,XQAIENS,.01,"E") 61 S XMTEXT="XQAMESG(" 62 ; ZEXCEPT: XTMUNIT - Defined if unit tests are being run 63 D:'$D(XTMUNIT) SENDMESG 64 Q 65 ; 66 ACTIVATE(XQAUSER,XQALIEN) ; activates a surrogate 67 N X0,XQALFM,XQALSURO,XQALSTRT,XQALEND 68 S X0=$G(^XTV(8992,XQAUSER,2,XQALIEN,0)) Q:X0="" S XQALSTRT=$P(X0,U),XQALSURO=$P(X0,U,2),XQALEND=$P(X0,U,3) 69 S X0=^XTV(8992,XQAUSER,0) 70 I $P(X0,U,2)>0,$P(X0,U,3)'>$$NOW^XLFDT() D REMVSURO(XQAUSER) ; If we are activaing a new surrogate, if one exists simply remove. 71 K XQALFM S XQALFM(8992,XQAUSER_",",.03)=XQALSTRT 72 S XQALFM(8992,XQAUSER_",",.02)=XQALSURO 73 S XQALFM(8992,XQAUSER_",",.04)=$S($G(XQALEND)>0:XQALEND,1:"@") 74 D FILE^DIE("","XQALFM") 75 Q 76 ; 77 ; usage $$SETSURO1(XQAUSER,XQALSURO,XQALSTRT,XQALEND) returns 0 if invalid, otherwise > 0 78 SETSURO1(XQAUSER,XQALSURO,XQALSTRT,XQALEND) ; SR. This should be used instead of SETSURO 79 I $G(XQALSTRT)'>0 S XQALSTRT=$$NOW^XLFDT() 80 N XQAVAL 81 S XQAVAL=$$CYCLIC(XQALSURO,XQAUSER,XQALSTRT,$G(XQALEND)) I XQAVAL'>0 Q XQAVAL ; Can't use as surrogate 82 D SETSUROX(XQAUSER,XQALSURO,XQALSTRT,$G(XQALEND)) ; P443 83 Q XQALSURO 84 ; 85 CHKREMV ; 86 N DIR,XQAI,XQASLIST,XQAVAL,YVAL,Y 87 ; ZEXCEPT: XQAUSER (EXTERNAL VALUE) 88 D SUROLIST^XQALSUR1(XQAUSER,.XQASLIST) 89 W !,"Current Surrogate(s):",?35,"START DATE",?60,"END DATE" 90 F XQAI=0:0 S XQAI=$O(XQASLIST(XQAI)) Q:XQAI'>0 W !,XQAI," ",$P(XQASLIST(XQAI),U,2),?35,$$FMTE^XLFDT($P(XQASLIST(XQAI),U,3)),?60,$$FMTE^XLFDT($P(XQASLIST(XQAI),U,4)) 91 W ! I XQASLIST'>0 W !," No current surrogates",! Q 92 S DIR(0)="Y",DIR("A")="Do you want to REMOVE "_$S(XQASLIST>1:"a",1:"THIS")_" surrogate recipient",DIR("?")="A surrogate will receive your alerts until they are removed as surrogate." D ^DIR K DIR Q:Y'>0 93 S Y=1 I XQASLIST>1 S DIR(0)="L^1:"_XQASLIST,DIR("A")="Enter a list (comma separated, e.g., 1,2) of the surrogate(s) to remove" D ^DIR K DIR 94 I Y>0 S YVAL=Y F XQAI=1:1 S XQAVAL=+$P(YVAL,",",XQAI) Q:XQAVAL'>0 D REMVSURO(XQAUSER,$P(XQASLIST(XQAVAL),U),$P(XQASLIST(XQAVAL),U,3)) 95 Q 96 ; 97 ; P366 - added OPTIONAL second and third arguments to permit deletion of a specific pending surrogate and start date 98 REMVSURO(XQAUSER,XQALSURO,XQALSTRT) ; SR - ends the currently active surrogate relationship 99 I $G(XQAUSER)'>0 Q 100 D REMVSURO^XQALSUR1(XQAUSER,$G(XQALSURO),$G(XQALSTRT)) 101 Q 102 ; 103 ; P366 - added OPTIONAL second and third arguments to determine surrogate for specified time range 104 CURRSURO(XQAUSER,XQASTRT,XQAEND) ;SR. - returns current surrogate for user or -1 usage $$CURRSURO^XQALSURO(DUZ) 105 N X,ACTIVE,XQANOW,XQASTR1,XQAIVAL,XQA0,XQAI 106 D CHEKSUBS^XQALSUR2(XQAUSER) 107 I $G(XQASTRT)>0 Q $$DATESURO^XQALSUR1(XQAUSER,XQASTRT,$G(XQAEND)) ; P366 - check for current in specified date/times 108 ; 109 ; P366 - find the latest start time which is now or past or the first one in the future 110 S XQANOW=$$NOW^XLFDT() D 111 . S XQAIVAL=0,XQASTR1=0 112 . F XQASTRT=0:0 S XQASTRT=$O(^XTV(8992,XQAUSER,2,"B",XQASTRT)) Q:XQASTRT'>0 Q:XQASTRT'<XQANOW S XQASTR1=XQASTRT F XQAI=0:0 S XQAI=$O(^XTV(8992,XQAUSER,2,"B",XQASTRT,XQAI)) Q:XQAI'>0 D 113 . . S XQAEND=$P(^XTV(8992,XQAUSER,2,XQAI,0),U,3) I (XQAEND="")!(XQAEND>XQANOW) S XQAIVAL=XQAI 114 . . Q 115 . ; to be compatible with the past, if there is not a current surrogate, show the next scheduled on the zero node if there is one 116 . I XQAIVAL=0 S XQASTRT=$O(^XTV(8992,XQAUSER,2,"B",XQASTR1)) Q:XQASTRT="" F XQAI=0:0 S XQAI=$O(^XTV(8992,XQAUSER,2,"B",XQASTRT,XQAI)) Q:XQAI'>0 D Q:XQAIVAL>0 117 . . S XQAEND=$P(^XTV(8992,XQAUSER,2,XQAI,0),U,3) I (XQAEND="")!(XQAEND>XQANOW) S XQAIVAL=XQAI 118 . . Q 119 . I XQAIVAL>0 S XQA0=^XTV(8992,XQAUSER,2,XQAIVAL,0),XQASTRT=^XTV(8992,XQAUSER,0) I ($P(XQA0,U,2)'=$P(XQASTRT,U,2))!($P(XQA0,U)'=$P(XQASTRT,U,3))!(+$P(XQA0,U,3)'=+$P(XQASTRT,U,4)) D ACTIVATE(XQAUSER,XQAIVAL) 120 . Q 121 ; P366 - end 122 S X=$G(^XTV(8992,XQAUSER,0)) 123 ; now check for a CURRENT surrogate, already started and not expired or cyclic 124 I $P(X,U,2)>0,+$P(X,U,3)'>XQANOW D I $P($G(^XTV(8992,XQAUSER,0)),U,2)>0 Q +$P(^XTV(8992,XQAUSER,0),U,2) 125 . N DATE ; Get Current date/time to check date/times if present 126 . ; FOLLOWING LINES MODIFIED IN P443 TO ELIMINATE A STACK ERROR WHEN SURROGATE WAS CIRCULAR 127 . ; Current Date/time past End date for surrogate 128 . S DATE=$P(X,U,4) I (DATE>0&(DATE<XQANOW)) D REMVSURO(XQAUSER) Q 129 . N XQASURO,XQASURO1 S XQASURO1=+$P(^XTV(8992,XQAUSER,0),U,2) 130 . ; REMOVE IF SURROGATE IS USER 131 . I XQASURO1=XQAUSER D REMVSURO(XQAUSER) Q 132 . N XQALLIST S XQALLIST(XQAUSER)="" 133 . ; REMOVE IF CYCLES BACK TO USER - thought about removing inactive, but best to let those be handled by groups for unprocessed alerts 134 . F S XQASURO=$P($G(^XTV(8992,XQASURO1,0)),U,2) Q:XQASURO'>0 Q:'$$ISACTIVE(XQASURO) S XQASURO1=XQASURO D 135 . . I $D(XQALLIST(XQASURO)) D REMVSURO(XQASURO) S XQASURO1=XQAUSER K XQALLIST S XQALLIST(XQAUSER)="" Q 136 . . S XQALLIST(XQASURO1)="" 137 . . Q 138 . ; END OF P443 MODIFICATION 139 . Q 140 Q -1 141 ; 142 ISACTIVE(XQAUSER) ; checks for whether a surrogate relationship is active or not (returns 0 or 1) 143 N DATA 144 S DATA=$G(^XTV(8992,XQAUSER,0)) Q:$P(DATA,U,2)="" 0 ; NO SURROGATE SPECIFIED 145 I $P(DATA,U,3)>0,$P(DATA,U,3)>$$NOW^XLFDT() Q 0 ; START DATE/TIME NOT YET 146 I $P(DATA,U,4)>0,$P(DATA,U,4)<$$NOW^XLFDT() Q 0 ; PAST END DATE/TIME 147 Q 1 148 ; 149 ACTVSURO(XQAUSER) ;SR. - returns the actual surrogate at this time 150 N CURRSURO,NEXTSURO,SURODATA,NOW 151 S NOW=$$NOW^XLFDT() 152 S CURRSURO=$$CURRSURO(XQAUSER),SURODATA=$$GETSURO(XQAUSER) I (CURRSURO'>0)!(+$P(SURODATA,U,3)>NOW)!('(+$$ACTIVE^XUSER(CURRSURO))) Q -1 153 F S NEXTSURO=$$CURRSURO(CURRSURO),SURODATA=$$GETSURO(CURRSURO) Q:NEXTSURO'>0 Q:+$P(SURODATA,U,3)>NOW Q:'(+$$ACTIVE^XUSER(NEXTSURO)) S CURRSURO=NEXTSURO 154 Q CURRSURO 155 ; 156 GETSURO(XQAUSER) ;SR. - returns data for surrogate for user including times 157 I $$CURRSURO(XQAUSER)'>0 Q "" 158 N GLOBREF,IENS,X 159 S IENS=XQAUSER_",",GLOBREF=$NA(^TMP($J,"XQALSURO")) K @GLOBREF 160 D GETS^DIQ(8992,IENS,".02;.03;.04","IE",GLOBREF) 161 S GLOBREF=$NA(@GLOBREF@(8992,IENS)) 162 S X=$G(@GLOBREF@(.02,"I"))_U_$G(@GLOBREF@(.02,"E"))_U_$G(@GLOBREF@(.03,"I"))_U_$G(@GLOBREF@(.04,"I")) 163 K @GLOBREF 164 Q X 165 ; 166 GETFOR ;OPT. 167 N XQAUSER,VALUES,XQACNT,DIR,DIRUT,I,Y 168 S DIR(0)="PD^200:AEMQ",DIR("A",1)="View Users who have selected a specified User as their Surrogate." 169 S DIR("A")="Select User (NEW PERSON entry)" 170 D ^DIR K DIR Q:Y'>0 W " ",$P(Y,U,2) 171 S XQAUSER=+Y 172 D SUROFOR(.VALUES,XQAUSER) I VALUES'>0 W !,"No entries found.",!! Q 173 S XQACNT=0 K DIRUT F I=0:0 S I=$O(VALUES(I)) Q:I'>0 D:(XQACNT>(IOSL-4)) Q:$D(DIRUT) W !,?5,$P(VALUES(I),U,2) S XQACNT=XQACNT+1 174 . S DIR(0)="E" D ^DIR K DIR 175 . Q 176 K DIRUT 177 Q 178 ; 179 SUROLIST(XQAUSER,XQALIST) ; SR. returns list of current and scheduled surrogates for XQAUSER 180 D SUROLIST^XQALSUR1(XQAUSER,.XQALIST) 181 Q 182 ; 183 SUROFOR(LIST,XQAUSER) ;SR. - returns list of users XQAUSER is acting as a surrogate for 184 I $G(XQAUSER)="" Q 185 N I,COUNT S I=0,COUNT=0 F S I=$O(^XTV(8992,"AC",XQAUSER,I)) Q:I'>0 I $$CURRSURO(I)>0 D 186 . S COUNT=COUNT+1,LIST(COUNT)=I_U_$$GET1^DIQ(200,(I_","),".01","E")_U_$$GET1^DIQ(8992,(I_","),".03","E")_U_$$GET1^DIQ(8992,(I_","),".04","E") 187 S LIST=COUNT 188 Q 189 ; 190 SENDMESG ; 191 N XMY,XMDUZ,XMCHAN 192 ; ZEXCEPT: XQALSURO (EXTERNAL VALUE) 193 S XMY(XQALSURO)="",XMDUZ=.5 194 D ^XMD 195 Q 1 XQALSURO ;ISC-SF.SEA/JLI - SURROGATES FOR ALERTS ;9/6/05 15:13 2 ;;8.0;KERNEL;**114,125,173,285,366**;Jul 10, 1995 3 ;; 4 Q 5 OTHRSURO ; OPT:- XQALERT SURROGATE SET/REMOVE -- OTHERS SPECIFY SURROGATE FOR SELECTED USER 6 N XQAUSER,DIR,Y 7 S DIR(0)="PD^200:AEMQ",DIR("A",1)="SURROGATE related to which" 8 S DIR("A")="NEW PERSON entry" 9 D ^DIR K DIR Q:Y'>0 W " ",$P(Y,U,2) 10 S XQAUSER=+Y 11 G SURROGAT 12 Q 13 ; 14 SURROGAT ; USER SPECIFICATION OF SURROGATE 15 I '$D(XQAUSER) N XQAUSER S XQAUSER=DUZ 16 D SURRO1^XQALSUR1(XQAUSER) 17 Q 18 ; P366 - optional start and end dates added to permit identification of cyclical surrogates in specific times 19 CYCLIC(XQALSURO,XQAUSER,XQASTRT,XQAEND) ; code added to prevent cyclical surrogates 20 I $G(XQASTRT)>0 Q $$DCYCLIC^XQALSUR1(XQALSURO,XQAUSER,XQASTRT,$G(XQAEND)) 21 N XQALSTRT 22 I XQALSURO=XQAUSER Q "You cannot specify yourself as your own surrogate!" 23 S XQALSTRT=$$CURRSURO(XQALSURO) I XQALSTRT>0 D 24 . I XQALSTRT=XQAUSER S XQALSURO="YOU are designated as the surrogate for this user - can't do it!" Q 25 . F S XQALSTRT=$$CURRSURO(XQALSTRT) Q:XQALSTRT'>0 I XQALSTRT=XQAUSER S XQALSURO="This forms a circle which leads back to you - can't do it!" Q 26 . Q 27 Q XQALSURO 28 ; 29 SETSURO(XQAUSER,XQALSURO,XQALSTRT,XQALEND) ; SR 30 N XQALFM,XQALIEN,XQAIENS 31 I $G(XQAUSER)'>0 Q 32 I $G(XQALSURO)'>0 Q 33 I '$D(^XTV(8992,XQAUSER,0)) D 34 . N XQALFM,XQALFM1 35 . S XQALFM1(1)=XQAUSER 36 . S XQALFM(8992,"+1,",.01)=XQAUSER 37 . D UPDATE^DIE("","XQALFM","XQALFM1") 38 . Q 39 S XQAIENS=XQAUSER_"," 40 ; P366 - force no start date/time to NOW 41 ; P366 - change to force anything less than NOW to NOW - 8/22/05 42 I $G(XQALSTRT)<$$NOW^XLFDT() S XQALSTRT=$$NOW^XLFDT() 43 ; P366 - add values to new multiple 44 S XQALFM(8992.02,"+1,"_XQAIENS,.01)=XQALSTRT 45 S XQALFM(8992.02,"+1,"_XQAIENS,.02)=XQALSURO 46 I XQALEND>0 S XQALFM(8992.02,"+1,"_XQAIENS,.03)=XQALEND 47 K XQALIEN D UPDATE^DIE("","XQALFM","XQALIEN") 48 ; P366 - if start date time is already in effect - place in old locations to make active 49 I XQALSTRT'>$$NOW^XLFDT() D ACTIVATE(XQAUSER,XQALIEN(1)) 50 N XQAMESG,XMSUB,XMTEXT 51 S XQAMESG(1,0)="You have been specified as a surrogate recipient for alerts for" 52 S XQAMESG(2,0)=$$GET1^DIQ(200,XQAIENS,.01,"E")_" (IEN="_XQAUSER_") effective "_$$FMTE^XLFDT(XQALSTRT) 53 I $G(XQALEND)'>0 S XQAMESG(2,0)=XQAMESG(2,0)_"." 54 E S XQAMESG(3,0)="until "_$$FMTE^XLFDT(XQALEND) 55 S XMSUB="Surrogate Recipient for "_$$GET1^DIQ(200,XQAIENS,.01,"E") 56 S XMTEXT="XQAMESG(" 57 D:'$D(XQATEST) SENDMESG 58 Q 59 ; 60 ACTIVATE(XQAUSER,XQALIEN) ; activates a surrogate 61 N X0,XQALFM,XQALSURO,XQALSTRT,XQALEND 62 S X0=$G(^XTV(8992,XQAUSER,2,XQALIEN,0)) Q:X0="" S XQALSTRT=$P(X0,U),XQALSURO=$P(X0,U,2),XQALEND=$P(X0,U,3) 63 S X0=^XTV(8992,XQAUSER,0) 64 I $P(X0,U,2)>0,$P(X0,U,3)'>$$NOW^XLFDT() D REMVSURO(XQAUSER) ; If we are activaing a new surrogate, if one exists simply remove. 65 K XQALFM S XQALFM(8992,XQAUSER_",",.03)=XQALSTRT 66 S XQALFM(8992,XQAUSER_",",.02)=XQALSURO 67 S XQALFM(8992,XQAUSER_",",.04)=$S($G(XQALEND)>0:XQALEND,1:"@") 68 D FILE^DIE("","XQALFM") 69 Q 70 ; 71 ; usage $$SETSURO1(XQAUSER,XQALSURO,XQALSTRT,XQALEND) returns 0 if invalid, otherwise > 0 72 SETSURO1(XQAUSER,XQALSURO,XQALSTRT,XQALEND) ; SR. This should be used instead of SETSURO 73 I $G(XQALSTRT)'>0 S XQALSTRT=$$NOW^XLFDT() 74 N XQAVAL 75 S XQAVAL=$$CYCLIC(XQALSURO,XQAUSER,XQALSTRT,$G(XQALEND)) I XQAVAL'>0 Q XQAVAL ; Can't use as surrogate 76 D SETSURO(XQAUSER,XQALSURO,XQALSTRT,$G(XQALEND)) 77 Q XQALSURO 78 ; 79 CHKREMV ; 80 N DIR,XQAI,XQASLIST,XQAVAL,YVAL,Y 81 ; ZEXCEPT: XQAUSER (EXTERNAL VALUE) 82 D SUROLIST^XQALSUR1(XQAUSER,.XQASLIST) 83 W !,"Current Surrogate(s):",?35,"START DATE",?60,"END DATE" 84 F XQAI=0:0 S XQAI=$O(XQASLIST(XQAI)) Q:XQAI'>0 W !,XQAI," ",$P(XQASLIST(XQAI),U,2),?35,$$FMTE^XLFDT($P(XQASLIST(XQAI),U,3)),?60,$$FMTE^XLFDT($P(XQASLIST(XQAI),U,4)) 85 W ! I XQASLIST'>0 W !," No current surrogates",! Q 86 S DIR(0)="Y",DIR("A")="Do you want to REMOVE "_$S(XQASLIST>1:"a",1:"THIS")_" surrogate recipient",DIR("?")="A surrogate will receive your alerts until they are removed as surrogate." D ^DIR K DIR Q:Y'>0 87 S Y=1 I XQASLIST>1 S DIR(0)="L^1:"_XQASLIST,DIR("A")="Enter a list (comma separated, e.g., 1,2) of the surrogate(s) to remove" D ^DIR K DIR 88 I Y>0 S YVAL=Y F XQAI=1:1 S XQAVAL=+$P(YVAL,",",XQAI) Q:XQAVAL'>0 D REMVSURO(XQAUSER,$P(XQASLIST(XQAVAL),U),$P(XQASLIST(XQAVAL),U,3)) 89 Q 90 ; 91 ; P366 - added OPTIONAL second and third arguments to permit deletion of a specific pending surrogate and start date 92 REMVSURO(XQAUSER,XQALSURO,XQALSTRT) ; SR - ends the currently active surrogate relationship 93 I $G(XQAUSER)'>0 Q 94 D REMVSURO^XQALSUR1(XQAUSER,$G(XQALSURO),$G(XQALSTRT)) 95 Q 96 ; 97 ; P366 - added OPTIONAL second and third arguments to determine surrogate for specified time range 98 CURRSURO(XQAUSER,XQASTRT,XQAEND) ;SR. - returns current surrogate for user or -1 usage $$CURRSURO^XQALSURO(DUZ) 99 N X,ACTIVE,XQANOW,XQASTR1,XQAIVAL,XQA0,XQAI 100 D CHEKSUBS^XQALSUR2(XQAUSER) 101 I $G(XQASTRT)>0 Q $$DATESURO^XQALSUR1(XQAUSER,XQASTRT,$G(XQAEND)) ; P366 - check for current in specified date/times 102 ; 103 ; P366 - find the latest start time which is now or past or the first one in the future 104 S XQANOW=$$NOW^XLFDT() 105 ;I $P($G(^XTV(8992,XQAUSER,0)),U,2)'>0 D 106 D 107 . S XQAIVAL=0,XQASTR1=0 108 . F XQASTRT=0:0 S XQASTRT=$O(^XTV(8992,XQAUSER,2,"B",XQASTRT)) Q:XQASTRT'>0 Q:XQASTRT'<XQANOW S XQASTR1=XQASTRT F XQAI=0:0 S XQAI=$O(^XTV(8992,XQAUSER,2,"B",XQASTRT,XQAI)) Q:XQAI'>0 D 109 . . S XQAEND=$P(^XTV(8992,XQAUSER,2,XQAI,0),U,3) I (XQAEND="")!(XQAEND>XQANOW) S XQAIVAL=XQAI 110 . . Q 111 . ; to be compatible with the past, if there is not a current surrogate, show the next scheduled on the zero node if there is one 112 . I XQAIVAL=0 S XQASTRT=$O(^XTV(8992,XQAUSER,2,"B",XQASTR1)) Q:XQASTRT="" F XQAI=0:0 S XQAI=$O(^XTV(8992,XQAUSER,2,"B",XQASTRT,XQAI)) Q:XQAI'>0 D Q:XQAIVAL>0 113 . . S XQAEND=$P(^XTV(8992,XQAUSER,2,XQAI,0),U,3) I (XQAEND="")!(XQAEND>XQANOW) S XQAIVAL=XQAI 114 . . Q 115 . I XQAIVAL>0 S XQA0=^XTV(8992,XQAUSER,2,XQAIVAL,0),XQASTRT=^XTV(8992,XQAUSER,0) I ($P(XQA0,U,2)'=$P(XQASTRT,U,2))!($P(XQA0,U)'=$P(XQASTRT,U,3))!(+$P(XQA0,U,3)'=+$P(XQASTRT,U,4)) D ACTIVATE(XQAUSER,XQAIVAL) 116 . Q 117 ; P366 - end 118 S X=$G(^XTV(8992,XQAUSER,0)) 119 ; now check for a CURRENT surrogate, already started and not expired or cyclic 120 I $P(X,U,2)>0,+$P(X,U,3)'>XQANOW D I $P($G(^XTV(8992,XQAUSER,0)),U,2)>0 Q +$P(^XTV(8992,XQAUSER,0),U,2) 121 . N DATE ; Get Current date/time to check date/times if present 122 . ; Current Date/time past End date for surrogate or cyclic relationship remove checks for new surrogate 123 . S DATE=$P(X,U,4) I (DATE>0&(DATE<XQANOW))!('$$CYCLIC($P(X,U,2),XQAUSER)) D REMVSURO(XQAUSER) 124 . Q 125 Q -1 126 ; 127 ACTVSURO(XQAUSER) ;SR. - returns the actual surrogate at this time 128 N CURRSURO,NEXTSURO,SURODATA,NOW 129 S NOW=$$NOW^XLFDT() 130 S CURRSURO=$$CURRSURO(XQAUSER),SURODATA=$$GETSURO(XQAUSER) I (CURRSURO'>0)!(+$P(SURODATA,U,3)>NOW)!('(+$$ACTIVE^XUSER(CURRSURO))) Q -1 131 F S NEXTSURO=$$CURRSURO(CURRSURO),SURODATA=$$GETSURO(CURRSURO) Q:NEXTSURO'>0 Q:+$P(SURODATA,U,3)>NOW Q:'(+$$ACTIVE^XUSER(NEXTSURO)) S CURRSURO=NEXTSURO 132 Q CURRSURO 133 ; 134 GETSURO(XQAUSER) ;SR. - returns data for surrogate for user including times 135 I $$CURRSURO(XQAUSER)'>0 Q "" 136 N GLOBREF,IENS,X 137 S IENS=XQAUSER_",",GLOBREF=$NA(^TMP($J,"XQALSURO")) K @GLOBREF 138 D GETS^DIQ(8992,IENS,".02;.03;.04","IE",GLOBREF) 139 S GLOBREF=$NA(@GLOBREF@(8992,IENS)) 140 S X=$G(@GLOBREF@(.02,"I"))_U_$G(@GLOBREF@(.02,"E"))_U_$G(@GLOBREF@(.03,"I"))_U_$G(@GLOBREF@(.04,"I")) 141 K @GLOBREF 142 Q X 143 ; 144 GETFOR ;OPT. 145 N XQAUSER,VALUES,XQACNT,DIR,DIRUT,I,Y 146 S DIR(0)="PD^200:AEMQ",DIR("A",1)="View Users who have selected a specified User as their Surrogate." 147 S DIR("A")="Select User (NEW PERSON entry)" 148 D ^DIR K DIR Q:Y'>0 W " ",$P(Y,U,2) 149 S XQAUSER=+Y 150 D SUROFOR(.VALUES,XQAUSER) I VALUES'>0 W !,"No entries found.",!! Q 151 S XQACNT=0 K DIRUT F I=0:0 S I=$O(VALUES(I)) Q:I'>0 D:(XQACNT>(IOSL-4)) Q:$D(DIRUT) W !,?5,$P(VALUES(I),U,2) S XQACNT=XQACNT+1 152 . S DIR(0)="E" D ^DIR K DIR 153 . Q 154 K DIRUT 155 Q 156 ; 157 SUROLIST(XQAUSER,XQALIST) ; SR. returns list of current and scheduled surrogates for XQAUSER 158 D SUROLIST^XQALSUR1(XQAUSER,.XQALIST) 159 Q 160 ; 161 SUROFOR(LIST,XQAUSER) ;SR. - returns list of users XQAUSER is acting as a surrogate for 162 I $G(XQAUSER)="" Q 163 N I,COUNT S I=0,COUNT=0 F S I=$O(^XTV(8992,"AC",XQAUSER,I)) Q:I'>0 I $$CURRSURO(I)>0 D 164 . S COUNT=COUNT+1,LIST(COUNT)=I_U_$$GET1^DIQ(200,(I_","),".01","E")_U_$$GET1^DIQ(8992,(I_","),".03","E")_U_$$GET1^DIQ(8992,(I_","),".04","E") 165 S LIST=COUNT 166 Q 167 ; 168 SENDMESG ; 169 N XMY,XMDUZ,XMCHAN 170 ; ZEXCEPT: XQALSURO (EXTERNAL VALUE) 171 S XMY(XQALSURO)="",XMDUZ=.5 172 D ^XMD 173 Q -
WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQARPRT2.m
r613 r623 1 XQARPRT2 ;DCN/BUF,JLI/OAK-OIFO - LOOKUP PROVIDER ALERTS ;4/9/07 10:16 2 ;;8.0;KERNEL;**316,443**;Jul 10, 1995;Build 4 3 ; Based on the original routine AEKALERT 4 Q 5 EN ; OPT - interactive lists alerts from start date for a single user based on contents of alert tracking file 6 N DIR,XQADOC S DIR(0)="PO^200:EMZ" D ^DIR K DIR Q:$D(DIRUT) Q:Y'>0 S XQADOC=+Y 7 EN1 ; 8 N XQASDATE,XQAWORDS,XQADISP,%ZIS,ZTRTN,ZTDESC,ZTSAVE,POP,XQAU1N4 9 D DATES Q:Y'>0 10 D WORDS() Q:$D(DIRUT) K Y 11 S %ZIS="MQ" D ^%ZIS Q:POP I $D(IO("Q")) K IO("Q") S ZTRTN="DQ1^XQARPRT2",ZTDESC="List of User Alerts",ZTSAVE("*")="" D ^%ZTLOAD W:$G(ZTSK)>0 !,"Task number is ",ZTSK K ZTSK Q 12 DQ1 ; 13 N XQANWID,XQAIEN,XQADATE,XQANODE0,XQACTR,HEADERID,XQATOT 14 S HEADERID="User "_$$GET1^DIQ(200,XQADOC_",",.01)_" (DFN="_XQADOC_")" 15 U IO 16 D HEADER(HEADERID,1) 17 S XQAIEN=$O(^XTV(8992.1,"D",XQASDATE-.0000001)) I XQAIEN>0 S XQAIEN=$O(^(XQAIEN,0)) ; find starting point instead of having to work up through x-ref 18 I XQAIEN>0 F S XQAIEN=$O(^XTV(8992.1,"R",XQADOC,XQAIEN)) Q:XQAIEN'>0 D Q:$D(DIRUT)!(XQADATE>XQAEDATE) 19 . S XQANODE0=$G(^XTV(8992.1,XQAIEN,0)),XQADATE=$P(XQANODE0,"^",2) Q:(XQADATE<XQASDATE)!(XQADATE>XQAEDATE) 20 . D PRNTATRK(XQAIEN) 21 D HEADER(HEADERID,0) 22 D ^%ZISC 23 K XQADATE,XQACTR,DATA,DIR,DIRUT,XQADOC,XQAIEN,XQANODE0,XQASDATE,Y 24 Q 25 ; 26 WORDS(TYPE) ; Allow user to select alerts containing only certain words 27 S DIR(0)="Y",DIR("A")="Do you want to "_$S($G(TYPE)'="":"count",1:"list")_" only alerts containing specific words or phrase(s)" 28 S DIR("?",1)="You can enter one or more words or phrases which you want to be used to" 29 S DIR("?",2)="select the alerts to be listed. If you enter NO, all for the selected" 30 S DIR("?",3)="individual in the selected time period will be selected. If you enter" 31 S DIR("?",4)="YES, you will be prompted to enter a word or phrase. You will be prompted" 32 S DIR("?",5)="again, and you may enter as many word or phrase entries as you want." 33 S DIR("?",6)="Comparisons will NOT be case specific." 34 S DIR("?",7)="" 35 S DIR("?",8)="HOWEVER ALL WORDS OR PHRASES ENTERED MUST BE IN THE MESSAGE FOR AN ALERT" 36 S DIR("?")="TO BE SELECTED." 37 D ^DIR K DIR Q:Y'>0 38 ; 39 F J=1:1 W:J>1 !?7,"--- OR ---",!,"Enter another set of words or phrases that should",!,"be matched independently of the previous entr"_$S(J>2:"ies",1:"y") D Q:'$D(XQAWORDS(J)) 40 . W !?10,"ALL words or phrases connected by -AND- must appear in the",!?10,"message for an alert to be selected" 41 . S DIR("?",1)="Enter a word, at least three characters long, or phrase, without regard to" 42 . S DIR("?",2)="case, that you want to be required for selection of alerts to be listed." 43 . S DIR("?",3)="If more than one word or phrase are specified, ALL of them must be in alerts" 44 . S DIR("?")="which will be listed." 45 . F I=1:1 S DIR(0)="FO^3:",DIR("A")="Enter "_$S(I=1:"a",1:"another")_" word or phrase" W:I>1 !?10,"-AND-" D ^DIR Q:(Y="")!(Y["^") S XQAWORDS(J,I)=$$UP^XLFSTR(Y) 46 . K DIR,DIRUT 47 . Q 48 ; 49 I $D(XQAWORDS)>1,$G(TYPE)="" D 50 . S DIR(0)="SO^1:Both Action and Info Only;2:Action Alerts;3:Info Only Alerts",DIR("?",1)="Select whether alerts listed should be alerts involving actions (2), info",DIR("?")="only or text only alerts (3), or both (1)." 51 . S DIR("A")="Select Alert Type(s) desired",DIR("B")=1 D ^DIR K DIR S:Y'>0 Y=1 K DIRUT S XQADISP=+Y 52 . Q 53 Q 54 ; 55 USER ;USER ENTRY POINT 56 N DIR,XQADOC S XQADOC=DUZ 57 G EN1 58 ; 59 DATES ; 60 S DIR(0)="DO^::EX",DIR("B")="TODAY",DIR("A")="START DATE" D ^DIR K DIR Q:Y'>0 S XQASDATE=+Y 61 I XQASDATE<$$OLDEST() W !?10,"The earliest date in the alert tracking file is ",$$FMTE^XLFDT($$OLDEST(),"D") S XQASDATE=$$OLDEST() 62 I $D(XQA1U4N) W !,"*** WARNING ***: Do not specify too many days - each entry in the Alert Tracking",!,"file must be checked for the date range specified.",! S DIR("B")=$$FMTE^XLFDT(XQASDATE) 63 S DIR(0)="DO^"_XQASDATE_":DT",DIR("A")="END DATE" D ^DIR K DIR Q:$D(DIRUT) I Y>0 S XQAEDATE=Y+.24 64 Q 65 ; 66 PRNTATRK(IEN) ; Print data for an entry from the alert tracking file 67 N XQANODE0,XQADATE,Y,XQANEN,XQAMSG,XQAOPT,XQAROU,XQAMSGUC 68 S XQANODE0=$G(^XTV(8992.1,IEN,0)),XQADATE=$P(XQANODE0,"^",2) 69 S XQAMSG=$G(^XTV(8992.1,IEN,1)),XQAOPT=$P(XQAMSG,U,2),XQAROU=$P(XQAMSG,U,3,4),XQAMSG=$P(XQAMSG,U) 70 S XQAOPT=$S(XQAOPT>0:" [OPT]",1:"") S XQAROU=$S((XQAROU'="")&(XQAROU'="^"):" [ROU]",1:"") S XQAOPT=$S(XQAOPT'="":XQAOPT,XQAROU'="":XQAROU,1:" ") 71 I $D(XQAWORDS)>1 S XQAMSGUC=$$UP^XLFSTR(XQAMSG) D Q:XQAMSGUC="" 72 . N XQAMSG1,J,I S XQAMSG1=XQAMSGUC F J=0:0 S J=$O(XQAWORDS(J)) Q:J'>0 S XQAMSGUC=XQAMSG1 D Q:XQAMSGUC'="" 73 . . F I=0:0 S I=$O(XQAWORDS(J,I)) Q:I'>0 I XQAMSGUC'[XQAWORDS(J,I) S XQAMSGUC="" Q 74 . . I XQAMSGUC'="",XQADISP'=1 D 75 . . . I XQADISP=2,XQAOPT="",XQAROU="" S XQAMSGUC="" 76 . . . I XQADISP=3,(XQAOPT'="")!(XQAROU'="") S XQAMSGUC="" 77 . . . Q 78 . . Q 79 . Q 80 S XQANEN=$$FMTE^XLFDT(XQADATE,"5Z")_XQAOPT_" ien="_IEN 81 W !,$E(XQAMSG,1,IOM-1) W !?35,XQANEN S XQATOT=XQATOT+1 82 S XQACTR=XQACTR+2 I XQACTR>(IOSL-4) D Q:$D(DIRUT) S XQACTR=0 83 . I $D(ZTQUEUED) W @IOF 84 . E U IO(0) S DIR(0)="E" D ^DIR K DIR W ! 85 . U IO 86 . Q 87 Q 88 ; 89 HEADER(XQANAME,DOFF) ; Output header at start of report XQANAME indicates who report is for 90 W:DOFF @IOF W:'DOFF ! W $S('DOFF:"Found "_XQATOT_" ",1:""),$S($D(XQAWORDS)>1:"Selected ",1:""),"Alerts for ",XQANAME,!," for dates ",$$FMTE^XLFDT(XQASDATE)," through " 91 N OUTDATE S OUTDATE=$$FMTE^XLFDT(XQAEDATE,"D") I 'DOFF,$D(XQADATE),XQADATE<XQAEDATE,'$D(ZTQUEUED) S OUTDATE=$$FMTE^XLFDT(XQADATE) 92 W OUTDATE S XQACTR=2 93 D WORDHDR 94 W ! S XQACTR=XQACTR+1 95 S XQATOT=0 96 Q 97 ; 98 WORDHDR ; 99 N I,J 100 F I=0:0 S I=$O(XQAWORDS(I)) Q:I'>0 W:I>1 !?10,"--- OR ---" D 101 . F J=0:0 S J=$O(XQAWORDS(I,J)) Q:J'>0 W !?5,$S(J=1:"Selected alerts containing:",1:" and containing:"),?35,XQAWORDS(I,J) S XQACTR=XQACTR+1 102 . Q 103 Q 104 DTPT ; OPT - GIVEN DATE AND PATIENT, TAKE A LOOK AT ALL USING 'D' X-REF 105 ; for one day and for 1 patient list data in alert tracking file related to patient 106 N DIR,XQANAME,XQADFN,XQA1U4N,XQASDATE,XQAEDATE,XQA1U4NP,XQAWORDS 107 S DIR(0)="PO^2:EMZ" D ^DIR Q:Y'>0 S XQANAME=$P(Y,"^",2),XQADFN=+Y,XQA1U4N=$$GET1^DIQ(2,XQADFN_",",.0905),XQA1U4NP="("_XQA1U4N_")" 108 D CHEKSCAN(XQADFN) Q:$D(DIRUT) 109 D DATES Q:Y'>0 110 D WORDS() K Y Q:$D(DIRUT) 111 S %ZIS="MQ" D ^%ZIS Q:POP I $D(IO("Q")) K IO("Q") S ZTRTN="DTPTDQ^XQARPRT2",ZTDESC="List of Patient Alerts",ZTSAVE("*")="" D ^%ZTLOAD W:$G(ZTSK)>0 !,"Task number is ",ZTSK K ZTSK Q 112 DTPTDQ ; 113 N XQANWID,FOUND,ONE,ZERO,XQACTR,XQAIEN,XQATYPE,XQADATE,HEADERID,XQATOT 114 S HEADERID="Patient "_$$GET1^DIQ(2,XQADFN_",",.01)_" ("_$$GET1^DIQ(2,XQADFN_",",.0905)_")" 115 D HEADER(HEADERID,1) 116 S XQADATE=XQASDATE-0.0000001 F S XQADATE=$O(^XTV(8992.1,"D",XQADATE)) Q:(XQADATE'>0)!(XQADATE>XQAEDATE) D Q:$D(DIRUT) 117 . S XQAIEN=0 F S XQAIEN=$O(^XTV(8992.1,"D",XQADATE,XQAIEN)) Q:XQAIEN="" S ONE=$G(^XTV(8992.1,XQAIEN,1)),ZERO=$G(^(0)),XQATYPE=$E(ZERO,1,3) D Q:$D(DIRUT) 118 . . S FOUND=0 119 . . I (XQATYPE="DVB")!(XQATYPE="OR,") I $P(ZERO,U,4)=XQADFN S FOUND=1 120 . . I (XQATYPE="GMA"),$P(ONE,U)[XQANAME S FOUND=1 121 . . I (XQATYPE="TIU"),$P(ONE,U)[$E(XQANAME,1,9),$P(ONE,U)[XQA1U4NP S FOUND=1 122 . . I FOUND D PRNTATRK(XQAIEN) 123 . . Q 124 . Q 125 D HEADER(HEADERID,0) 126 Q 127 ; 128 CHEKSCAN(XQADFN) ; Output a list of dates when OR, and DVB alerts are found 129 N DIR,OLDEST,X,Y,XQASDATE,XX,CNT,COL,BASECNT,I 130 W !!! S DIR(0)="Y",DIR("A")="Do you want to scan for a list of dates that have at least some alerts for this patient",DIR("A",1)="The quick scan method used here will not pick up some alerts," 131 S DIR("A",2)="but should give an indication of when alerts might be found.",DIR("A",3)="" 132 D ^DIR K DIR Q:$D(DIRUT) I Y D 133 . K ^TMP("XQARPRT2",$J) 134 . N OLDEST S OLDEST=$$FMTE^XLFDT($$OLDEST(),"5DZ") 135 . S DIR(0)="SO^;1:1 Week ago;2:1 month ago;3:3 months ago;4:6 months ago;5:1 year ago;6:As far back as possible",DIR("A")="Select a period for starting",DIR("A",1)="The oldest entry in your Alert Tracking file is from "_OLDEST,DIR("A",2)="" 136 . D ^DIR K DIR Q:Y'>0 137 . S X=$S(Y=1:"1W",Y=2:"1M",Y=3:"3M",Y=4:"6M",Y=5:"12M",1:"1000M"),X="T-"_X D ^%DT S XQASDATE=Y 138 . F I=0:0 S I=$O(^XTV(8992.1,"C",XQADFN,I)) Q:I'>0 S ZERO=$P(^XTV(8992.1,I,0),U,2) I ZERO'<XQASDATE S ^TMP("XQARPRT2",$J,(ZERO\1))=$G(^TMP("XQARPRT2",$J,(ZERO\1)))+1 139 . ; Output date and number found in vertical columns, with (if lots of dates) three columns per screen 140 . I $D(^TMP("XQARPRT2",$J)) W !,"Dates and number of alerts found in () [may not be all of them]" 141 . ; S CNT=0,COL=1,BASECNT=0 F I=0:0 S I=$O(^TMP("XQARPRT2",$J,I)) Q:I'>0 S CNT=CNT+1,XX(CNT)=$G(XX(CNT))_$$FMTE^XLFDT(I,"5DZ")_" ("_^(I)_")"_" " I (CNT-BASECNT)>(IOSL-4) S COL=COL+1 S:'(COL#3) BASECNT=CNT S CNT=BASECNT 142 . S CNT=2 F I=0:0 S I=$O(^TMP("XQARPRT2",$J,I)) Q:I'>0 S CNT=CNT+1,XX(CNT\3)=$G(XX(CNT\3))_$$FMTE^XLFDT(I,"5DZ")_" ("_^(I)_")"_" " 143 . F I=0:0 S I=$O(XX(I)) Q:I'>0 W !,XX(I) 144 . Q 145 Q 146 ; 147 VIEWTRAK ; OPT. View an entry in the Alert Tracking file in Captioned mode 148 D VIEWTRAK^XQARPRT1 149 Q 150 ; 151 OLDEST() ; Returns date of oldest entry in alert tracking file 152 Q $$OLDEST^XQARPRT1() 1 XQARPRT2 ;DCN/BUF,JLI/OAK-OIFO - LOOKUP PROVIDER ALERTS 25 SEP 98 ;9/3/03 11:15 2 ;;8.0;KERNEL;**316**;Jul 10, 1995 3 ; Based on the original routine AEKALERT 4 Q 5 EN ; OPT - interactive lists alerts from start date for a single user based on contents of alert tracking file 6 N DIR,XQADOC S DIR(0)="PO^200:EMZ" D ^DIR K DIR Q:$D(DIRUT) Q:Y'>0 S XQADOC=+Y 7 EN1 ; 8 N XQASDATE,XQAWORDS,XQADISP,%ZIS,ZTRTN,ZTDESC,ZTSAVE,POP,XQAU1N4 9 D DATES Q:Y'>0 10 D WORDS() Q:$D(DIRUT) K Y 11 S %ZIS="MQ" D ^%ZIS Q:POP I $D(IO("Q")) K IO("Q") S ZTRTN="DQ1^XQARPRT2",ZTDESC="List of User Alerts",ZTSAVE("*")="" D ^%ZTLOAD W:$G(ZTSK)>0 !,"Task number is ",ZTSK K ZTSK Q 12 DQ1 ; 13 N XQANWID,XQAIEN,XQADATE,XQANODE0,XQACTR,HEADERID,XQATOT 14 S HEADERID="User "_$$GET1^DIQ(200,XQADOC_",",.01)_" (DFN="_XQADOC_")" 15 D HEADER(HEADERID,1) 16 S XQAIEN=$O(^XTV(8992.1,"D",XQASDATE-.0000001)) I XQAIEN>0 S XQAIEN=$O(^(XQAIEN,0)) ; find starting point instead of having to work up through x-ref 17 I XQAIEN>0 F S XQAIEN=$O(^XTV(8992.1,"R",XQADOC,XQAIEN)) Q:XQAIEN'>0 D Q:$D(DIRUT)!(XQADATE>XQAEDATE) 18 . S XQANODE0=$G(^XTV(8992.1,XQAIEN,0)),XQADATE=$P(XQANODE0,"^",2) Q:(XQADATE<XQASDATE)!(XQADATE>XQAEDATE) 19 . D PRNTATRK(XQAIEN) 20 D HEADER(HEADERID,0) 21 K XQADATE,XQACTR,DATA,DIR,DIRUT,XQADOC,XQAIEN,XQANODE0,XQASDATE,Y 22 Q 23 ; 24 WORDS(TYPE) ; Allow user to select alerts containing only certain words 25 S DIR(0)="Y",DIR("A")="Do you want to "_$S($G(TYPE)'="":"count",1:"list")_" only alerts containing specific words or phrase(s)" 26 S DIR("?",1)="You can enter one or more words or phrases which you want to be used to" 27 S DIR("?",2)="select the alerts to be listed. If you enter NO, all for the selected" 28 S DIR("?",3)="individual in the selected time period will be selected. If you enter" 29 S DIR("?",4)="YES, you will be prompted to enter a word or phrase. You will be prompted" 30 S DIR("?",5)="again, and you may enter as many word or phrase entries as you want." 31 S DIR("?",6)="Comparisons will NOT be case specific." 32 S DIR("?",7)="" 33 S DIR("?",8)="HOWEVER ALL WORDS OR PHRASES ENTERED MUST BE IN THE MESSAGE FOR AN ALERT" 34 S DIR("?")="TO BE SELECTED." 35 D ^DIR K DIR Q:Y'>0 36 ; 37 F J=1:1 W:J>1 !?7,"--- OR ---",!,"Enter another set of words or phrases that should",!,"be matched independently of the previous entr"_$S(J>2:"ies",1:"y") D Q:'$D(XQAWORDS(J)) 38 . W !?10,"ALL words or phrases connected by -AND- must appear in the",!?10,"message for an alert to be selected" 39 . S DIR("?",1)="Enter a word, at least three characters long, or phrase, without regard to" 40 . S DIR("?",2)="case, that you want to be required for selection of alerts to be listed." 41 . S DIR("?",3)="If more than one word or phrase are specified, ALL of them must be in alerts" 42 . S DIR("?")="which will be listed." 43 . F I=1:1 S DIR(0)="FO^3:",DIR("A")="Enter "_$S(I=1:"a",1:"another")_" word or phrase" W:I>1 !?10,"-AND-" D ^DIR Q:(Y="")!(Y["^") S XQAWORDS(J,I)=$$UP^XLFSTR(Y) 44 . K DIR,DIRUT 45 . Q 46 ; 47 I $D(XQAWORDS)>1,$G(TYPE)="" D 48 . S DIR(0)="SO^1:Both Action and Info Only;2:Action Alerts;3:Info Only Alerts",DIR("?",1)="Select whether alerts listed should be alerts involving actions (2), info",DIR("?")="only or text only alerts (3), or both (1)." 49 . S DIR("A")="Select Alert Type(s) desired",DIR("B")=1 D ^DIR K DIR S:Y'>0 Y=1 K DIRUT S XQADISP=+Y 50 . Q 51 Q 52 ; 53 USER ;USER ENTRY POINT 54 N DIR,XQADOC S XQADOC=DUZ 55 G EN1 56 ; 57 DATES ; 58 S DIR(0)="DO^::EX",DIR("B")="TODAY",DIR("A")="START DATE" D ^DIR K DIR Q:Y'>0 S XQASDATE=+Y 59 I XQASDATE<$$OLDEST() W !?10,"The earliest date in the alert tracking file is ",$$FMTE^XLFDT($$OLDEST(),"D") S XQASDATE=$$OLDEST() 60 I $D(XQA1U4N) W !,"*** WARNING ***: Do not specify too many days - each entry in the Alert Tracking",!,"file must be checked for the date range specified.",! S DIR("B")=$$FMTE^XLFDT(XQASDATE) 61 S DIR(0)="DO^"_XQASDATE_":DT",DIR("A")="END DATE" D ^DIR K DIR Q:$D(DIRUT) I Y>0 S XQAEDATE=Y+.24 62 Q 63 ; 64 PRNTATRK(IEN) ; Print data for an entry from the alert tracking file 65 N XQANODE0,XQADATE,Y,XQANEN,XQAMSG,XQAOPT,XQAROU,XQAMSGUC 66 S XQANODE0=$G(^XTV(8992.1,IEN,0)),XQADATE=$P(XQANODE0,"^",2) 67 S XQAMSG=$G(^XTV(8992.1,IEN,1)),XQAOPT=$P(XQAMSG,U,2),XQAROU=$P(XQAMSG,U,3,4),XQAMSG=$P(XQAMSG,U) 68 S XQAOPT=$S(XQAOPT>0:" [OPT]",1:"") S XQAROU=$S((XQAROU'="")&(XQAROU'="^"):" [ROU]",1:"") S XQAOPT=$S(XQAOPT'="":XQAOPT,XQAROU'="":XQAROU,1:" ") 69 I $D(XQAWORDS)>1 S XQAMSGUC=$$UP^XLFSTR(XQAMSG) D Q:XQAMSGUC="" 70 . N XQAMSG1,J,I S XQAMSG1=XQAMSGUC F J=0:0 S J=$O(XQAWORDS(J)) Q:J'>0 S XQAMSGUC=XQAMSG1 D Q:XQAMSGUC'="" 71 . . F I=0:0 S I=$O(XQAWORDS(J,I)) Q:I'>0 I XQAMSGUC'[XQAWORDS(J,I) S XQAMSGUC="" Q 72 . . I XQAMSGUC'="",XQADISP'=1 D 73 . . . I XQADISP=2,XQAOPT="",XQAROU="" S XQAMSGUC="" 74 . . . I XQADISP=3,(XQAOPT'="")!(XQAROU'="") S XQAMSGUC="" 75 . . . Q 76 . . Q 77 . Q 78 S XQANEN=$$FMTE^XLFDT(XQADATE,"5Z")_XQAOPT_" ien="_IEN 79 W !,$E(XQAMSG,1,IOM-1) W !?35,XQANEN S XQATOT=XQATOT+1 80 S XQACTR=XQACTR+2 I XQACTR>(IOSL-4) D Q:$D(DIRUT) S XQACTR=0 81 . I $D(ZTQUEUED) W @IOF 82 . E S DIR(0)="E" D ^DIR K DIR W ! 83 . Q 84 Q 85 ; 86 HEADER(XQANAME,DOFF) ; Output header at start of report XQANAME indicates who report is for 87 W:DOFF @IOF W:'DOFF ! W $S('DOFF:"Found "_XQATOT_" ",1:""),$S($D(XQAWORDS)>1:"Selected ",1:""),"Alerts for ",XQANAME,!," for dates ",$$FMTE^XLFDT(XQASDATE)," through " 88 N OUTDATE S OUTDATE=$$FMTE^XLFDT(XQAEDATE,"D") I 'DOFF,$D(XQADATE),XQADATE<XQAEDATE,'$D(ZTQUEUED) S OUTDATE=$$FMTE^XLFDT(XQADATE) 89 W OUTDATE S XQACTR=2 90 D WORDHDR 91 W ! S XQACTR=XQACTR+1 92 S XQATOT=0 93 Q 94 ; 95 WORDHDR ; 96 N I,J 97 F I=0:0 S I=$O(XQAWORDS(I)) Q:I'>0 W:I>1 !?10,"--- OR ---" D 98 . F J=0:0 S J=$O(XQAWORDS(I,J)) Q:J'>0 W !?5,$S(J=1:"Selected alerts containing:",1:" and containing:"),?35,XQAWORDS(I,J) S XQACTR=XQACTR+1 99 . Q 100 Q 101 DTPT ; OPT - GIVEN DATE AND PATIENT, TAKE A LOOK AT ALL USING 'D' X-REF 102 ; for one day and for 1 patient list data in alert tracking file related to patient 103 N DIR,XQANAME,XQADFN,XQA1U4N,XQASDATE,XQAEDATE,XQA1U4NP,XQAWORDS 104 S DIR(0)="PO^2:EMZ" D ^DIR Q:Y'>0 S XQANAME=$P(Y,"^",2),XQADFN=+Y,XQA1U4N=$$GET1^DIQ(2,XQADFN_",",.0905),XQA1U4NP="("_XQA1U4N_")" 105 D CHEKSCAN(XQADFN) Q:$D(DIRUT) 106 D DATES Q:Y'>0 107 D WORDS() K Y Q:$D(DIRUT) 108 S %ZIS="MQ" D ^%ZIS Q:POP I $D(IO("Q")) K IO("Q") S ZTRTN="DTPTDQ^XQARPRT2",ZTDESC="List of Patient Alerts",ZTSAVE("*")="" D ^%ZTLOAD W:$G(ZTSK)>0 !,"Task number is ",ZTSK K ZTSK Q 109 DTPTDQ ; 110 N XQANWID,FOUND,ONE,ZERO,XQACTR,XQAIEN,XQATYPE,XQADATE,HEADERID,XQATOT 111 S HEADERID="Patient "_$$GET1^DIQ(2,XQADFN_",",.01)_" ("_$$GET1^DIQ(2,XQADFN_",",.0905)_")" 112 D HEADER(HEADERID,1) 113 S XQADATE=XQASDATE-0.0000001 F S XQADATE=$O(^XTV(8992.1,"D",XQADATE)) Q:(XQADATE'>0)!(XQADATE>XQAEDATE) D Q:$D(DIRUT) 114 . S XQAIEN=0 F S XQAIEN=$O(^XTV(8992.1,"D",XQADATE,XQAIEN)) Q:XQAIEN="" S ONE=$G(^XTV(8992.1,XQAIEN,1)),ZERO=$G(^(0)),XQATYPE=$E(ZERO,1,3) D Q:$D(DIRUT) 115 . . S FOUND=0 116 . . I (XQATYPE="DVB")!(XQATYPE="OR,") I $P(ZERO,U,4)=XQADFN S FOUND=1 117 . . I (XQATYPE="GMA"),$P(ONE,U)[XQANAME S FOUND=1 118 . . I (XQATYPE="TIU"),$P(ONE,U)[$E(XQANAME,1,9),$P(ONE,U)[XQA1U4NP S FOUND=1 119 . . I FOUND D PRNTATRK(XQAIEN) 120 . . Q 121 . Q 122 D HEADER(HEADERID,0) 123 Q 124 ; 125 CHEKSCAN(XQADFN) ; Output a list of dates when OR, and DVB alerts are found 126 N DIR,OLDEST,X,Y,XQASDATE,XX,CNT,COL,BASECNT,I 127 W !!! S DIR(0)="Y",DIR("A")="Do you want to scan for a list of dates that have at least some alerts for this patient",DIR("A",1)="The quick scan method used here will not pick up some alerts," 128 S DIR("A",2)="but should give an indication of when alerts might be found.",DIR("A",3)="" 129 D ^DIR K DIR Q:$D(DIRUT) I Y D 130 . K ^TMP("XQARPRT2",$J) 131 . N OLDEST S OLDEST=$$FMTE^XLFDT($$OLDEST(),"5DZ") 132 . S DIR(0)="SO^;1:1 Week ago;2:1 month ago;3:3 months ago;4:6 months ago;5:1 year ago;6:As far back as possible",DIR("A")="Select a period for starting",DIR("A",1)="The oldest entry in your Alert Tracking file is from "_OLDEST,DIR("A",2)="" 133 . D ^DIR K DIR Q:Y'>0 134 . S X=$S(Y=1:"1W",Y=2:"1M",Y=3:"3M",Y=4:"6M",Y=5:"12M",1:"1000M"),X="T-"_X D ^%DT S XQASDATE=Y 135 . F I=0:0 S I=$O(^XTV(8992.1,"C",XQADFN,I)) Q:I'>0 S ZERO=$P(^XTV(8992.1,I,0),U,2) I ZERO'<XQASDATE S ^TMP("XQARPRT2",$J,(ZERO\1))=$G(^TMP("XQARPRT2",$J,(ZERO\1)))+1 136 . ; Output date and number found in vertical columns, with (if lots of dates) three columns per screen 137 . I $D(^TMP("XQARPRT2",$J)) W !,"Dates and number of alerts found in () [may not be all of them]" 138 . ; S CNT=0,COL=1,BASECNT=0 F I=0:0 S I=$O(^TMP("XQARPRT2",$J,I)) Q:I'>0 S CNT=CNT+1,XX(CNT)=$G(XX(CNT))_$$FMTE^XLFDT(I,"5DZ")_" ("_^(I)_")"_" " I (CNT-BASECNT)>(IOSL-4) S COL=COL+1 S:'(COL#3) BASECNT=CNT S CNT=BASECNT 139 . S CNT=2 F I=0:0 S I=$O(^TMP("XQARPRT2",$J,I)) Q:I'>0 S CNT=CNT+1,XX(CNT\3)=$G(XX(CNT\3))_$$FMTE^XLFDT(I,"5DZ")_" ("_^(I)_")"_" " 140 . F I=0:0 S I=$O(XX(I)) Q:I'>0 W !,XX(I) 141 . Q 142 Q 143 ; 144 VIEWTRAK ; OPT. View an entry in the Alert Tracking file in Captioned mode 145 D VIEWTRAK^XQARPRT1 146 Q 147 ; 148 OLDEST() ; Returns date of oldest entry in alert tracking file 149 Q $$OLDEST^XQARPRT1() -
WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQCHK.m
r613 r623 1 XQCHK ; SEA/MJM - Check security on option # XQCY ;5/20/08 2 ;;8.0;KERNEL;**47,110,149,303,427,503**;Jul 10, 1995;Build 2 3 ;;"Per VHA Directive 2004-038, this routine should not be modified". 4 ; 5 Q:'$D(XQCY)!(XQCY<1) S:'$D(XQJMP) XQJMP=0 6 I '$D(XQY0) S XQY0=^DIC(19,+XQCY,0) 7 I '$D(XQCY0) S XQSAV=XQY0,XQY=XQCY D SET Q:XQCY<0 S XQCY0=XQY0,XQY0=XQSAV 8 CHK I XQCY0="" S XQCY=-1 G OUT 9 I $P(XQCY0,U,3)'="" S XQCY=-1 G OUT 10 N XQRT S XQRT=$$CHCKL^XQCHK2(XQCY0,DUZ) I +XQRT S XQCY=-2 G OUT ; add this line to check all Locks 11 I $L($P(XQCY0,U,6)) S %="" F %XQI=1:1 S %=$P($P(XQCY0,U,6),",",%XQI) Q:%="" I '$D(^XUSEC(%,DUZ)) S XQCY=-2 G OUT ; remove 12 N XQRT S XQRT=$$CHCKRL^XQCHK2(XQCY0,DUZ) I +XQRT S XQCY=-3 G OUT ; add this line to check all Reversed Locks 13 I $L($P(XQCY0,U,16)) S %="" F %XQI=1:1 S %=$P($P(XQCY0,U,16),",",%XQI) Q:%="" I $D(^XUSEC(%,DUZ)) S XQCY=-3 G OUT ; remove 14 I $L($P(XQCY0,U,9)) S XQZ=$P(XQCY0,U,9) D ^XQDATE S X=% D XQO^XQ92 I X="" S XQCY=-4 G OUT 15 G:$P(XQCY0,U,10)'["y" OUT 16 S %=0 F %XQI=1:1 S %=$O(^DIC(19,XQCY,3.96,%,0)) Q:%="" I IOS=% G OUT 17 S XQCY=-5 G OUT 18 Q 19 ; 20 OUT K %,%XQI,XQCY0,%Y,XQZ 21 Q 22 ; 23 JMP ;Check all options in jump path in %XQJP returned as "" if not OK 24 S XQJMP=1 25 F %XQCI=1:1 S XQCY=$P(%XQJP,",",%XQCI) Q:XQCY="" S XQCY0=$G(^XUTL("XQO",XQDIC,"^",XQCY)),XQCY0=$P(XQCY0,U,2,99) D CHK S:XQCY<0 %XQJP="" 26 K %XQCI,XQCY,XQCY0 27 Q 28 ; 29 SET ;Produce the same XQY0 as SET1^XQ7 without the synonym 30 I '$D(^DIC(19,+XQY,0)) S XQY=-1 Q 31 S1 Q:XQY'>0 S XQY0=^DIC(19,+XQY,0),XQY0=$P(XQY0,U,1,2)_U_$S($P(XQY0,U,3)]"":1,1:"")_U_$P(XQY0,U,4)_U_U_$P(XQY0,U,6,99) 32 S %="" I $D(^DIC(19,+XQY,3.91)) F %XQI=0:0 S %XQI=$O(^DIC(19,+XQY,3.91,%XQI)) Q:%XQI=""!(%XQI'=+%XQI) I ^(%XQI,0)]"" S %=$S(%'="":%_";",1:"")_$P(^(0),U,1)_$P(^(0),U,2) 33 I %]"" S XQY0=$P(XQY0,U,1,8)_U_%_U_$P(XQY0,U,10,99) 34 I $P(XQY0,U,16),$D(^DIC(19,XQY,3)) S %=$P(^(3),U) I %'="" S XQY0=$P(XQY0,U,1,15)_U_%_U_$P(XQY0,U,17,99) 35 K %,%XQI 36 Q 37 ; 38 MES ;Messages for rejected options from a call to XQCHK 39 W $C(7) 40 I XQCY=-1 W !!?5,"==> Sorry, ",$S($D(XQPRMN):"your Primary Menu",1:"this option")," is out of order with the message:",!?10,$P(^DIC(19,XQY,0),U,3) 41 I XQCY=-2 W !!?5,"==> Sorry, ",$S($D(XQPRMN):"your Primary Menu",1:"this option")," is locked." 42 I XQCY=-3 W !!?5,"==> Sorry, ",$S($D(XQPRMN):"your Primary Menu",1:"this option")," has a reverse lock on it." 43 I XQCY=-4 W !!?5,"==> Sorry, ",$S($D(XQPRMN):"your Primary Menu",1:"this option")," not allowed right now." 44 I XQCY=-5 W !!?5,"==> Sorry, ",$S($D(XQPRMN):"your Primary Menu",1:"this option")," not allowed on this device." 45 Q 46 ; 47 OP ;Find out what option or protocol is in charge right now 48 ;Returns option or protocol name and text in XQOPT 49 S U="^",%XQ=0 50 I $D(XQORNOD) S %XQ=+XQORNOD,%XQ1=U_$P(XQORNOD,";",2),%XQ=@(%XQ1_%XQ_",0)"),XQOPT=$P(%XQ,U)_U_$P(%XQ,U,2) 51 I '$D(XQORNOD) S %XQ=$S($D(XQY)#2:XQY,1:0) I %XQ S %XQ1=^DIC(19,+%XQ,0),XQOPT=$P(%XQ1,U)_U_$P(%XQ1,U,2) 52 I '$D(XQOPT) S XQOPT="-1^Unknown" 53 K %XQ,%XQ1 54 Q 55 ; 56 OP1() ;Extrinsic function call returns 3 pieces: 1. "P", "O", or "U" for 57 ;Protocol, Option, or Unknown. 2: The Option or Protocol's name. 3: 58 ;3: Text name of the Protocol or Option. For example: 59 ; 60 ; O^EVE^System Manager's Menu 61 ; 62 N %,%XQ,%XQ1 63 S U="^",%XQ=0 64 I $D(XQORNOD) S %XQ=+XQORNOD,%XQ1=U_$P(XQORNOD,";",2),%XQ=@(%XQ1_%XQ_",0)"),%="P"_U_$P(%XQ,U)_U_$P(%XQ,U,2) 65 I '$D(XQORNOD) S %XQ=$S($D(XQY)#2:XQY,1:0) I %XQ S %XQ1=^DIC(19,+%XQ,0),%="O"_U_$P(%XQ1,U)_U_$P(%XQ1,U,2) 66 I '$D(%) S %="U"_U_"Unknown"_U_"No option or protocol data available" 67 Q % 68 ; 69 ACCESS(%XQUSR,%XQOP) ;Find out if a user has access to a particular option 70 Q $$ACCESS^XQCHK3(%XQUSR,%XQOP) 71 ; 72 OPACCES ;Entry point for the option that checks to see if a user has 73 ;access to a particular option by calling the above function. 74 D OPACCES^XQCHK3 75 Q 76 ; 77 KEYSET(XQU) ;Collect users keys and set them into ^TMP($J) 78 N %,XQI 79 S %=0 F XQI=0:1 S %=$O(^VA(200,XQU,51,"B",%)) Q:%="" S:$D(^DIC(19.1,%,0)) ^TMP($J,$P(^DIC(19.1,%,0),U),%)="" 80 Q 1 XQCHK ; SEA/MJM - Check security on option # XQCY ; [7/19/06 10:45am] 2 ;;8.0;KERNEL;**47,110,149,303,427**;Jul 10, 1995;Build 3 3 Q:'$D(XQCY)!(XQCY<1) S:'$D(XQJMP) XQJMP=0 4 I '$D(XQY0) S XQY0=^DIC(19,+XQCY,0) 5 I '$D(XQCY0) S XQSAV=XQY0,XQY=XQCY D SET Q:XQCY<0 S XQCY0=XQY0,XQY0=XQSAV 6 CHK I XQCY0="" S XQCY=-1 G OUT 7 I $P(XQCY0,U,3)'="" S XQCY=-1 G OUT 8 N XQRT S XQRT=$$CHCKL^XQCHK2(XQCY0,DUZ) I +XQRT S XQCY=-2 G OUT ; add this line to check all Locks 9 I $L($P(XQCY0,U,6)) S %="" F %XQI=1:1 S %=$P($P(XQCY0,U,6),",",%XQI) Q:%="" I '$D(^XUSEC(%,DUZ)) S XQCY=-2 G OUT ; remove 10 N XQRT S XQRT=$$CHCKRL^XQCHK2(XQCY0,DUZ) I +XQRT S XQCY=-3 G OUT ; add this line to check all Reversed Locks 11 I $L($P(XQCY0,U,16)) S %="" F %XQI=1:1 S %=$P($P(XQCY0,U,16),",",%XQI) Q:%="" I $D(^XUSEC(%,DUZ)) S XQCY=-3 G OUT ; remove 12 I $L($P(XQCY0,U,9)) S XQZ=$P(XQCY0,U,9) D ^XQDATE S X=% D XQO^XQ92 I X="" S XQCY=-4 G OUT 13 G:$P(XQCY0,U,10)'["y" OUT 14 S %=0 F %XQI=1:1 S %=$O(^DIC(19,XQCY,3.96,%,0)) Q:%="" I IOS=% G OUT 15 S XQCY=-5 G OUT 16 Q 17 ; 18 OUT ;I XQCY=-2 W !,"Locked...Do you have the key "_$P(XQRT,"^",2) 19 ;I XQCY=-3 W !,"Reversed Locked...Don't you have the key "_$P(XQRT,"^",2) 20 K %,%XQI,XQCY0,%Y,XQZ 21 Q 22 ; 23 JMP ;Check all options in jump path in %XQJP returned as "" if not OK 24 S XQJMP=1 25 F %XQCI=1:1 S XQCY=$P(%XQJP,",",%XQCI) Q:XQCY="" S XQCY0=$G(^XUTL("XQO",XQDIC,"^",XQCY)),XQCY0=$P(XQCY0,U,2,99) D CHK S:XQCY<0 %XQJP="" 26 K %XQCI,XQCY,XQCY0 27 Q 28 ; 29 SET ;Produce the same XQY0 as SET1^XQ7 without the synonym 30 I '$D(^DIC(19,+XQY,0)) S XQY=-1 Q 31 S1 Q:XQY'>0 S XQY0=^DIC(19,+XQY,0),XQY0=$P(XQY0,U,1,2)_U_$S($P(XQY0,U,3)]"":1,1:"")_U_$P(XQY0,U,4)_U_U_$P(XQY0,U,6,99) 32 S %="" I $D(^DIC(19,+XQY,3.91)) F %XQI=0:0 S %XQI=$O(^DIC(19,+XQY,3.91,%XQI)) Q:%XQI=""!(%XQI'=+%XQI) I ^(%XQI,0)]"" S %=$S(%'="":%_";",1:"")_$P(^(0),U,1)_$P(^(0),U,2) 33 I %]"" S XQY0=$P(XQY0,U,1,8)_U_%_U_$P(XQY0,U,10,99) 34 I $P(XQY0,U,16),$D(^DIC(19,XQY,3)) S %=$P(^(3),U) I %'="" S XQY0=$P(XQY0,U,1,15)_U_%_U_$P(XQY0,U,17,99) 35 K %,%XQI 36 Q 37 ; 38 MES ;Messages for rejected options from a call to XQCHK 39 W $C(7) 40 I XQCY=-1 W !!?5,"==> Sorry, ",$S($D(XQPRMN):"your Primary Menu",1:"this option")," is out of order with the message:",!?10,$P(^DIC(19,XQY,0),U,3) 41 I XQCY=-2 W !!?5,"==> Sorry, ",$S($D(XQPRMN):"your Primary Menu",1:"this option")," is locked." 42 I XQCY=-3 W !!?5,"==> Sorry, ",$S($D(XQPRMN):"your Primary Menu",1:"this option")," has a reverse lock on it." 43 I XQCY=-4 W !!?5,"==> Sorry, ",$S($D(XQPRMN):"your Primary Menu",1:"this option")," not allowed right now." 44 I XQCY=-5 W !!?5,"==> Sorry, ",$S($D(XQPRMN):"your Primary Menu",1:"this option")," not allowed on this device." 45 Q 46 ; 47 OP ;Find out what option or protocol is in charge right now 48 ;Returns option or protocol name and text in XQOPT 49 S U="^",%XQ=0 50 I $D(XQORNOD) S %XQ=+XQORNOD,%XQ1=U_$P(XQORNOD,";",2),%XQ=@(%XQ1_%XQ_",0)"),XQOPT=$P(%XQ,U)_U_$P(%XQ,U,2) 51 I '$D(XQORNOD) S %XQ=$S($D(XQY)#2:XQY,1:0) I %XQ S %XQ1=^DIC(19,+%XQ,0),XQOPT=$P(%XQ1,U)_U_$P(%XQ1,U,2) 52 I '$D(XQOPT) S XQOPT="-1^Unknown" 53 K %XQ,%XQ1 54 Q 55 ; 56 OP1() ;Extrinsic function call returns 3 pieces: 1. "P", "O", or "U" for 57 ;Protocol, Option, or Unknown. 2: The Option or Protocol's name. 3: 58 ;3: Text name of the Protocol or Option. For example: 59 ; 60 ; O^EVE^System Manager's Menu 61 ; 62 N %,%XQ,%XQ1 63 S U="^",%XQ=0 64 I $D(XQORNOD) S %XQ=+XQORNOD,%XQ1=U_$P(XQORNOD,";",2),%XQ=@(%XQ1_%XQ_",0)"),%="P"_U_$P(%XQ,U)_U_$P(%XQ,U,2) 65 I '$D(XQORNOD) S %XQ=$S($D(XQY)#2:XQY,1:0) I %XQ S %XQ1=^DIC(19,+%XQ,0),%="O"_U_$P(%XQ1,U)_U_$P(%XQ1,U,2) 66 I '$D(%) S %="U"_U_"Unknown"_U_"No option or protocol data available" 67 Q % 68 ; 69 ; 70 ACCESS(%XQUSR,%XQOP) ;Find out if a user has access to a particular option 71 ; 72 ; W $$ACCESS(DUZ,Option IEN) returns: 73 ; 74 ;-1:no such user in the New Person File 75 ;-2: User terminated or has no access code 76 ;-3: no such option in the Option File 77 ;0: no access found in any menu tree the user owns 78 ; 79 ; All other cases return a 4-piece string stating 80 ; access ^ menu tree IEN ^ a set of codes ^ key 81 ; 82 ;O^tree^codes^key: No access because of locks (see XQCODES below) 83 ; where 'tree' is the menu where access WOULD be allowed 84 ; and 'key' is the key preventing access 85 ;1^OpIEN^^: Access allowed through Primary Menu 86 ;2^OpIEN^codes^: Access found in the Common Options 87 ;3^OpIEN^codes^: Access found in top level of secondary option 88 ;4^OpIEN^codes^: Access through a the secondary menu tree OpIEN. 89 ; 90 ;XQCODES can contain: 91 ; N=No Primary Menu in the User File (warning only) 92 ; L=Locked and the user does not have the key (forces 0 in first piece) 93 ; R=Reverse lock and user has the key (forces 0 in first piece) 94 ; 95 I '$D(^VA(200,%XQUSR,0)) Q -1 96 N %,DT 97 S DT=$$HTFM^XLFDT($H,1) 98 S %=^VA(200,%XQUSR,0) I ($P(%,U,3)="")!($L($P(%,U,11))&($P(%,U,11)'>DT)) Q -2 99 ; 100 ;Convert %XQOP to its IEN if the name is passed 101 I +%XQOP'=%XQOP D 102 .I $D(^DIC(19,"B",%XQOP))<1 S %XQOP=0 Q 103 .E S %XQOP=$O(^DIC(19,"B",%XQOP,0)) 104 .Q 105 I '%XQOP Q -3 106 I '$D(^DIC(19,%XQOP,0)) Q -3 107 ; 108 N XQCODES,XQCOM,XQDIC,XQDONE,XQI,XQJ,XQKEY,XQOK,XQPM,XQRSLT,XQSEC,XQTREE 109 S (%,XQDONE,XQOK)=0,(XQRSLT,XQCODES,XQTREE)="" 110 ; 111 ; 112 ;Look in the user's primary menu tree 113 S XQPM=$P($G(^VA(200,%XQUSR,201)),"^") 114 I 'XQPM S XQCODES=XQCODES_"N" 115 ; 116 ; 117 I XQPM S XQDIC="P"_XQPM I $D(^XUTL("XQO",XQDIC,"^",%XQOP)) D 118 .D KEYS 119 .I XQCODES'["L"&(XQCODES'["M") S XQOK=1 120 .Q 121 I XQOK Q "1^"_XQPM_"^"_XQCODES 122 I XQCODES["L"!(XQCODES["R") S XQRSLT="0^"_XQPM_"^"_XQCODES_"^"_XQKEY 123 ; 124 ; Search the common options 125 S XQCOM=$O(^DIC(19,"B","XUCOMMAND",0)) 126 S XQDIC="PXU" 127 I $D(^XUTL("XQO",XQDIC,"^",%XQOP)) D 128 .D KEYS 129 .I XQCODES'["L"&(XQCODES'["R") S XQOK=1 130 .Q 131 I XQOK Q "2^"_XQCOM_"^"_XQCODES 132 I XQRSLT="" I XQCODES["L"!(XQCODES["R") S XQRSLT="0^"_XQCOM_"^"_XQCODES_"^"_XQKEY 133 ; 134 ;Check the top level of the secondary options 135 S XQDIC="U"_%XQUSR 136 I $D(^VA(200,%XQUSR,203,0)),$P(^(0),U,4)>0 D 137 .S XQJ=0,XQDONE=0 138 .F XQI=1:1 D Q:XQDONE 139 ..S XQJ=$O(^VA(200,%XQUSR,203,XQJ)) 140 ..I (XQJ'=+XQJ)!('XQJ) S XQDONE=1 Q 141 ..S XQSEC(XQI)=+^VA(200,%XQUSR,203,XQJ,0) 142 ..Q:XQSEC(XQI)'=%XQOP 143 ..D KEYS 144 ..I XQCODES'["L"&(XQCODES'["R") S XQOK=1 145 ..I XQRSLT="" I XQCODES["L"!(XQCODES["R") S XQRSLT="0^"_XQSEC(XQI)_"^"_XQCODES_"^"_XQKEY 146 ..Q 147 .Q 148 I XQOK Q "3^"_%XQOP_"^"_XQCODES 149 ; 150 ;If there are no secondaries quit here 151 I '$D(XQI)&((XQCODES["L")!(XQCODES["R")) Q XQRSLT 152 I '$D(XQI) Q 0 153 ; 154 ;Check each secondary menu tree 155 F XQK=1:1:XQI-1 Q:XQOK D 156 .S XQDIC="P"_XQSEC(XQK) 157 .Q:'$D(^XUTL("XQO",XQDIC,"^",%XQOP)) 158 .S XQTREE=$P(XQDIC,"P",2) 159 .D KEYS 160 .I XQCODES'["L"&(XQCODES'["R") S XQOK=1 161 .I XQRSLT="" I XQCODES["L"!(XQCODES["R") S XQRSLT="0^"_XQTREE_"^"_XQCODES_"^"_XQKEY 162 .Q 163 I XQOK Q "4^"_XQTREE_"^"_XQCODES 164 I XQRSLT]"" Q XQRSLT 165 ; 166 ;We doan find nothing nowhere 167 Q "0^^"_XQCODES 168 ; 169 KEYS ;Check for keys, reverse keys... 170 N XQK,XQN,XQOPIQ,KFG 171 D CHCK1^XQCHK1 Q:KFG=1 172 I $D(^XUTL("XQO",XQDIC,"^",%XQOP)) S XQOPIQ=^(%XQOP) 173 E S XQOPIQ=U_^DIC(19,%XQOP,0) 174 ; 175 I $L($P(XQOPIQ,U,7)) D 176 .S %=$P(XQOPIQ,U,7) 177 .F XQN=1:1 S XQK=$P(%,",",XQN) Q:XQK="" D 178 ..I '$D(^XUSEC(XQK,%XQUSR)) S XQCODES=XQCODES_"L",XQKEY=XQK 179 ..Q 180 .Q 181 ; 182 I $L($P(XQOPIQ,U,17)) D 183 .S %=$P(XQOPIQ,U,17) 184 .F XQN=1:1 S XQK=$P(%,",",XQN) Q:XQK="" D 185 ..I $D(^XUSEC(XQK,%XQUSR)) S XQCODES=XQCODES_"R",XQKEY=XQK 186 ..Q 187 .Q 188 Q 189 ; 190 OPACCES ;Entry point for the option that checks to see if a user has 191 ;access to a particular option by calling the above function. 192 N %,DIC,X,XQANS,XQCODES,XQK,XQKEY,XQOPT,XQOPN,XQPTR,XQRSLT,XQTREE,XQUSER,XQUSN,Y 193 ; 194 S DIC(0)="AEMNQ",DIC="^VA(200,",DIC("A")="Please enter the user's name: " D ^DIC 195 I $D(DUOUT)!($D(DTOUT)) D KILLFM Q 196 I Y=-1 W !!?5,"Sorry we couldn't find that user in the New Person File.",! 197 E S XQUSN=+Y,XQUSER=$P(Y,U,2) 198 I Y=-1 D KILLFM Q 199 D KILLFM 200 ; 201 S DIC(0)="AEMNQ",DIC="^DIC(19,",DIC("A")="Please enter the name of the option: " D ^DIC 202 I $D(DUOUT)!($D(DTOUT)) D KILLFM Q 203 I Y=-1 W !!?5,"Sorry we couldn't find that option.",! 204 E S XQOPN=+Y,XQOPT=$P(Y,U,2) 205 I Y=-1 D KILLFM Q 206 D KILLFM 207 ; 208 S XQANS=$$ACCESS(XQUSN,XQOPN) 209 ;W !,XQANS,! 210 ; 211 S XQRSLT=+XQANS,XQTREE="" 212 S XQPTR=$P(XQANS,U,2) I XQPTR>0 S XQTREE=$P(^DIC(19,$P(XQANS,U,2),0),U) 213 S XQCODES=$P(XQANS,U,3),XQKEY=$P(XQANS,U,4) 214 ; 215 I XQRSLT=-1 W !!?5,"User ",XQUSER," is not in the New Person File." 216 I XQRSLT=-2 W !!?5,"User ",XQUSER," has an active termination date,",!?5,"or no verify code." 217 I XQRSLT=-3 W !!?5,"Option ",XQOPT," is not in the Option File." 218 I XQRSLT=0 D 219 .W !!?5,"User ",XQUSER," does not have access to the option",!?5,XQOPT,"." 220 .I XQCODES["L" W !!?5,"There is a lock somewhere in the menu tree "_XQTREE,!?5,"and the user does not hold the key "_XQKEY_"." 221 .I XQCODES["R" W !!?5,"There is a reverse lock somewhere in the menu tree "_XQTREE,!?5,"and the user holds the key "_XQKEY_"." 222 .Q 223 I XQRSLT=1 W !!?5,"User ",XQUSER," has access to the option ",XQOPT,!?5,"through the primary menu ",XQTREE," (",$P(^DIC(19,XQPTR,0),U,2),")." 224 I XQRSLT=2 W !!?5,"User ",XQUSER," has access to the option ",XQOPT,!?5,"through the Common Options (XUCOMMAND)." 225 I XQRSLT=3 W !!?5,"User ",XQUSER," has access to the option ",XQOPT,!?5,"as a top-level secondary menu option." 226 I XQRSLT=4 W !!?5,"User ",XQUSER," has access to the option ",XQOPT,!?5,"through the secondary menu tree ",XQTREE," (",$P(^DIC(19,XQPTR,0),U,2),")." 227 W ! 228 ;W !!,%," ",XQUSER," ",XQOPT 229 Q 230 ; 231 KILLFM ;Kill off the FileMan variables 232 K D0,DI,DIC,DIE,DISYS,DQ,DR,DUOUT,DTOUT,X,Y 233 Q 234 ; 235 KEYSET(XQU) ;Collect users keys and set them into ^TMP($J) 236 N %,XQI 237 S %=0 F XQI=0:1 S %=$O(^VA(200,XQU,51,"B",%)) Q:%="" S:$D(^DIC(19.1,%,0)) ^TMP($J,$P(^DIC(19.1,%,0),U),%)="" 238 Q -
WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQCHK2.m
r613 r623 1 XQCHK2 ; OAK-BP/BDT - Internal APIs to check Keys for options; 5/20/08 2 ;;8.0;KERNEL;**427,503**;Jul 10, 1995;Build 2 3 ;;"Per VHA Directive 2004-038, this routine should not be modified". 4 Q 5 ;; These Internal Kernel APIs are using in the routine XQCHK 6 ;; to check Keys for options 7 ;; 8 CHCKL(XQCY0,XQDUZ) ;Entry point for checking all Locks for an option 9 ;; XQCY0 is $P(^XUTL("XQO",XQDIC,"^",%XQOP),"^",2,99) 10 ;; XQDUZ is IEN of user 11 ;; Return XQRT: Zero or 1^Key found that user needed for the option 12 S XQCY0=$G(XQCY0) 13 N XQI,XQY,XQX,XQRT,XQK S (XQRT,XQX)=0 14 ;check Key for the option; p457 15 S XQY=$P(XQCY0,"^"),XQX=$$GETIEN(XQY) 16 I +XQX S XQK=$$GET1^DIQ(19,XQX,3) 17 I $G(XQK)'="",'$D(^XUSEC(XQK,XQDUZ)) S XQRT=1_"^"_XQK Q XQRT 18 ;loop through higher menu options. 19 S XQY=$P(XQCY0,"^",5) 20 F XQI=1:1 S XQX=$P(XQY,",",XQI) Q:'XQX D 21 . I +XQX S XQK=$$GET1^DIQ(19,XQX,3) I XQK'="",'$D(^XUSEC(XQK,XQDUZ)) S XQRT=1_"^"_XQK Q 22 Q XQRT 23 ; 24 CHCKRL(XQCY0,XQDUZ) ;Entry point for checking all Reversed Locks for an option 25 ;; XQCY0 is $P(^XUTL("XQO",XQDIC,"^",%XQOP),"^",2,99) 26 ;; XQDUZ is IEN of user 27 ;; Return XQRT: Zero or 1^Reversed Key found that user has 28 S XQCY0=$G(XQCY0) 29 N XQI,XQY,XQX,XQRT,XQK S (XQRT,XQX)=0 30 ;check Reversed Key for the option; p457 31 S XQY=$P(XQCY0,"^"),XQX=$$GETIEN(XQY) 32 I +XQX S XQK=$$GET1^DIQ(19,XQX,3.01) 33 I $G(XQK)'="",$D(^XUSEC(XQK,XQDUZ)) S XQRT=1_"^"_XQK Q XQRT 34 ;loop through higher menu options. 35 S XQY=$P(XQCY0,"^",5) 36 F XQI=1:1 S XQX=$P(XQY,",",XQI) Q:'XQX D 37 . I +XQX S XQK=$$GET1^DIQ(19,XQX,3.01) I XQK'="",$D(^XUSEC(XQK,XQDUZ)) S XQRT=1_"^"_XQK Q 38 Q XQRT 39 ; 40 GETIEN(XQNAME) ;get IEN for an option; 457 41 ;; XQNAME is name of an option 42 ;; Retrun XQIEN: Null or IEN if existed 43 N XQIEN S XQIEN="" 44 I $G(XQNAME)="" Q XQIEN 45 I '$D(^DIC(19,"B",XQNAME)) Q XQIEN 46 S XQIEN=$O(^DIC(19,"B",XQNAME,XQIEN)) 47 Q XQIEN 48 ; 49 CHKTOPL(XQIEN,XQDUZ) ;Check Lock for the top level of the secondary options 50 ;this need to be called to check the top level first when check the 51 ;Locks for lower menu option because the 6th piece of ^XUTL does not 52 ;contain the IEN of the top menu option. 53 N XQRT,XQK S XQRT=0 54 I XQIEN'=+$G(XQIEN) Q XQRT 55 S XQK=$$GET1^DIQ(19,XQIEN,3) 56 I $G(XQK)'="",'$D(^XUSEC(XQK,XQDUZ)) S XQRT=1_"^"_XQK 57 Q XQRT 58 ; 59 CHKTOPRL(XQIEN,XQDUZ) ;Check Reversed Lock the top level of the secondary options 60 ;this need to be called to check the top level first when check the 61 ;Reversed Locks for lower menu option because the 6th piece of ^XUTL does not 62 ;contain the IEN of the top menu option. 63 N XQRT,XQK S XQRT=0 64 I XQIEN'=+$G(XQIEN) Q XQRT 65 S XQK=$$GET1^DIQ(19,XQIEN,3.01) 66 I $G(XQK)'="",$D(^XUSEC(XQK,XQDUZ)) S XQRT=1_"^"_XQK 67 Q XQRT 1 XQCHK2 ; BP/BDT - GET CALL FROM XQCHK ; [7/19/06 10:45am] 2 ;;8.0;KERNEL;**427**;Jul 10, 1995;Build 3 3 ; Entry point for checking all Locks for a option 4 CHCKL(XQCY0,DUZ) ; 5 N XQI,XQY,XQX,XQRT,XQK S (XQRT,XQX)=0 6 S XQY=$P(XQCY0,"^",5) 7 F XQI=1:1 S XQX=$P(XQY,",",XQI) Q:'XQX D 8 . I +XQX S XQK=$$GET1^DIQ(19,XQX,3) I XQK'="",'$D(^XUSEC(XQK,DUZ)) S XQRT=1_"^"_XQK Q 9 Q XQRT 10 ; Entry point for checking all Reversed Locks for a option 11 CHCKRL(XQCY0,DUZ) ; 12 N XQI,XQY,XQX,XQRT,XQK S (XQRT,XQX)=0 13 S XQY=$P(XQCY0,"^",5) 14 F XQI=1:1 S XQX=$P(XQY,",",XQI) Q:'XQX D 15 . I +XQX S XQK=$$GET1^DIQ(19,XQX,3.01) I XQK'="",$D(^XUSEC(XQK,DUZ)) S XQRT=1_"^"_XQK Q 16 Q XQRT -
WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQOR.m
r613 r623 1 XQOR 2 ;;8.0;KERNEL;**48,56,437**;Jul 10, 1995;Build 23 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 EN 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 EX 47 48 49 EN1 50 51 52 53 XQ 54 55 56 MSG(X,XQORMSG) 57 58 59 60 61 62 63 64 65 1 XQOR ; SLC/KCM - Prepare to Unwind Options ;4/3/07 16:21 2 ;;8.0;KERNEL;**48,56,437**;Jul 10, 1995;Build 22 3 ; Modified from FOIA VISTA, 4 ; Copyright (C) 2007 WorldVistA 5 ; 6 ; This program is free software; you can redistribute it and/or modify 7 ; it under the terms of the GNU General Public License as published by 8 ; the Free Software Foundation; either version 2 of the License, or 9 ; (at your option) any later version. 10 ; 11 ; This program is distributed in the hope that it will be useful, 12 ; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 ; GNU General Public License for more details. 15 ; 16 ; You should have received a copy of the GNU General Public License 17 ; along with this program; if not, write to the Free Software 18 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA 19 S DIC=19,DIC(0)="AEMQ" D ^DIC K DIC Q:Y<0 S X=+Y_";DIC(19," 20 EN ;Process options/protocols from top 21 ;From: Anywhere Entry: X,{DIC,XQORFLG} Exit: none 22 Q:$D(X)[0 K XQORPOP,XQORQUIT 23 I '$D(XQORS) S XQORS=0 K ^TMP("XQORS",$J) 24 S XQORS=XQORS+1 ;push 25 I $D(XQOR("HIJACK")) S X=XQOR("HIJACK"),DIC=101 K XQOR("HIJACK") 26 I X?1.N1";ORD(101,"!(X?1.N1";DIC(19,") S ^TMP("XQORS",$J,XQORS,"REF")="^"_$P(X,";",2)_+X_",",^TMP("XQORS",$J,XQORS,"VPT")=X 27 E S:$D(DIC)[0 DIC=19 S DIC(0)="N" D ^DIC S:Y>0 ^TMP("XQORS",$J,XQORS,"REF")=DIC_+Y_",",^TMP("XQORS",$J,XQORS,"VPT")=+Y_";"_$P(DIC,"^",2) K DIC G:Y<0 EX 28 S XQORNEST(XQORS)=^TMP("XQORS",$J,XQORS,"VPT"),XQORNEST=XQORS 29 G:'$D(@(^TMP("XQORS",$J,XQORS,"REF")_"0)")) EX S ^TMP("XQORS",$J,XQORS,"FLG")=$P(^(0),"^",4)_"^^" G:$P(^TMP("XQORS",$J,XQORS,"FLG"),"^")'?1A EX 30 ; LOCAL MOD VWSD SILENTMODE ECHO SDAM EVENTS (VARIABLE XQORMUTE) 31 I $L($P(@(^TMP("XQORS",$J,XQORS,"REF")_"0)"),"^",3)) W:'$D(ZTSK)&'$D(XQORMUTE) !!,$P(^(0),"^",3),! D:'$D(ZTSK)&'$D(XQORMUTE) READ^XQOR4 G EX 32 ;I $L($P(@(^TMP("XQORS",$J,XQORS,"REF")_"0)"),"^",3)) W !!,$P(^(0),"^",3),! D READ^XQOR4 G EX 33 ;END LOCAL MODE 34 D C19^XQOR4 G:Y<0 EX 35 S ^TMP("XQORS",$J,0,"FILE")=";"_$P(^TMP("XQORS",$J,XQORS,"VPT"),";",2),^TMP("XQORS",$J,XQORS,"INP")="" 36 I XQORS>1,$D(^TMP("XQORS",$J,XQORS-1,"ITM")),$D(^TMP("XQORS",$J,XQORS-1,"ITM",^TMP("XQORS",$J,XQORS-1,"ITM"),"IN")) S ^TMP("XQORS",$J,XQORS,"INP")=^TMP("XQORS",$J,XQORS-1,"ITM",^TMP("XQORS",$J,XQORS-1,"ITM"),"IN") 37 I XQORS>1,$D(XQORFLG("PI")) K XQORFLG("PI") S ^TMP("XQORS",$J,XQORS,"INP")=^TMP("XQORS",$J,XQORS-1,"INP") 38 S XQORNOD=^TMP("XQORS",$J,XQORS,"VPT"),XQORNOD(0)=^TMP("XQORS",$J,XQORS,"INP") 39 I XQORS>1,$D(^TMP("XQORS",$J,XQORS-1,"FLG")) S X=^TMP("XQORS",$J,XQORS-1,"FLG"),$P(^TMP("XQORS",$J,XQORS,"FLG"),"^",3)=$S($L($P(X,"^",5)):$P(X,"^",5),1:$P(X,"^",3)) 40 I ^TMP("XQORS",$J,0,"FILE")=";ORD(101,",$D(@(^TMP("XQORS",$J,XQORS,"REF")_"4)")) S:$P(^(4),"^",3)="Y" $P(^TMP("XQORS",$J,XQORS,"FLG"),"^",2)=1 41 I ^TMP("XQORS",$J,0,"FILE")=";DIC(19,",$P(^TMP("XQORS",$J,XQORS,"FLG"),"^")="M" S $P(^TMP("XQORS",$J,XQORS,"FLG"),"^",2)=1 42 I $D(XQORFLG) S:$D(XQORFLG("PS")) $P(^TMP("XQORS",$J,XQORS,"FLG"),"^",2)=+XQORFLG("PS") S:$D(XQORFLG("SH")) $P(^TMP("XQORS",$J,XQORS,"FLG"),"^",3)=+XQORFLG("SH") K XQORFLG 43 I $D(ORITMO) S $P(^TMP("XQORS",$J,XQORS,"FLG"),"^",6)=1 K ORITMO G REDO^XQOR1 44 I $P(^TMP("XQORS",$J,XQORS,"FLG"),"^")="D" N XQORDLG 45 G LOOP^XQOR1 46 EX K XQORNEST(XQORS),XQORFLG,XQORNOD,XQORY,^TMP("XQORS",$J,XQORS) S XQORS=XQORS-1,XQORNEST=XQORS ;pop 47 I XQORS=0 K XQORNEST,XQORS,^TMP("XQORS",$J),XQORSPEW 48 Q 49 EN1 ;Process items on option/protocol only (i.e., skip initial actions) 50 ;From: Anywhere Entry: X,DIC Exit: none 51 S ORITMO=1 G EN 52 Q 53 XQ ;From: Menuman Entry: XQOR Exit: XQOR 54 S X=+XQOR_";DIC(19," I $D(^DD(19,0,"VR")),^("VR")<5.9 G EN 55 G EN1 56 MSG(X,XQORMSG) ;Event point for HL7 messages 57 N DIC S DIC=101 58 I '$D(XQORHSTK) N XQORHSTK S XQORHSTK=-1 K ^TMP("XQORHSTK",$J) 59 S XQORHSTK=XQORHSTK+1 60 K ^TMP("XQORHSTK",$J,XQORHSTK) M ^TMP("XQORHSTK",$J,XQORHSTK)=XQORMSG 61 D EN^XQOR 62 S XQORHSTK=XQORHSTK-1 63 I XQORHSTK>-1 K XQORMSG M XQORMSG=^TMP("XQORHSTK",$J,XQORHSTK) 64 I XQORHSTK=-1 K ^TMP("XQORHSTK",$J) 65 Q -
WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQOR4.m
r613 r623 1 XQOR4 2 ;;8.0;KERNEL;**56,62,437**;Jul 10, 1995;Build 23 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 DJMP 20 21 22 23 24 25 26 27 28 29 30 31 32 DJMPX 33 34 DJMP1 35 36 SHDR 37 38 39 40 READ 41 42 43 44 C19 45 46 47 1 XQOR4 ; SLC/KCM - Process "^^" jump ;1/23/07 15:36 2 ;;8.0;KERNEL;**56,62,437**;Jul 10, 1995;Build 22 3 ; Modified from FOIA VISTA, 4 ; Copyright (C) 2007 WorldVistA 5 ; 6 ; This program is free software; you can redistribute it and/or modify 7 ; it under the terms of the GNU General Public License as published by 8 ; the Free Software Foundation; either version 2 of the License, or 9 ; (at your option) any later version. 10 ; 11 ; This program is distributed in the hope that it will be useful, 12 ; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 ; GNU General Public License for more details. 15 ; 16 ; You should have received a copy of the GNU General Public License 17 ; along with this program; if not, write to the Free Software 18 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA 19 DJMP ;From: STAK^XQOR1 20 Q:'$D(^TMP("XQORS",$J,XQORS,"ITM",^TMP("XQORS",$J,XQORS,"ITM"),"IN")) 21 I $D(VALMCC) N XQORLMGR S XQORLMGR="" D FULL^VALM1 ; List Mgr Running? 22 S X=^TMP("XQORS",$J,XQORS,"ITM",^TMP("XQORS",$J,XQORS,"ITM"),"IN") 23 I '$L($P(X,"^",3)) W !!,"For entry ""^^",$P(X,"^",4),""" -" 24 S X=$P(X,"^",4,99) D EAT^XQORM1 ;Q:$E(X,1,2)'="^^" 25 S X=$P(X,"=",1),D="K.ORWARD",DIC="^ORD(101,",DIC(0)="SE" D IX^DIC K DIC,D 26 I Y<0!('$D(^ORD(101,+Y,0))) W:(X'["^")&(X'["?") !!,">>> ",X," not found or selected. No action taken." D:(X'["^")&(X'["?") READ S X="" G DJMPX 27 S ORNSV=+Y 28 K X F I=1:1:XQORS I $P(^TMP("XQORS",$J,XQORS,"VPT"),";",2)="ORD(101,",$D(^ORD(101,+^TMP("XQORS",$J,XQORS,"VPT"),21)) D DJMP1 29 S X="" F I=0:0 S X=$O(X(X)) Q:X="" N @X 30 S X=ORNSV_";ORD(101," K ORNSV 31 D EN^XQOR 32 DJMPX I $D(XQORLMGR) S VALMBCK="R" ; Refresh List Mgr 33 Q 34 DJMP1 F J=0:0 S J=$O(^ORD(101,+^TMP("XQORS",$J,XQORS,"VPT"),21,J)) Q:J'>0 I $D(^ORD(101,+^TMP("XQORS",$J,XQORS,"VPT"),21,J,0)) S X=^(0) I X?1A.ANP!(X?1"%".ANP) S X(X)="" 35 Q 36 SHDR ;Display sub-header 37 Q:'$D(@(^TMP("XQORS",$J,XQORS,"REF")_"0)")) S X=$P(^(0),"^",2) W:X'?1." " !!?(36-($L(X)\2)),"--- "_X_" ---" 38 Q 39 ;VWSD LOCAL MOD STARTED HERE, XQ SILENT MODE . VARIABLE XQORMUTE 40 READ I '$D(XQORMUTE) W !,"Press RETURN to continue: " R X:$S($D(DTIME):DTIME,1:300) 41 ;READ W !,"Press RETURN to continue: " R X:$S($D(DTIME):DTIME,1:300) 42 ;END LOCAL MOD 43 Q 44 C19 N X0 S X0=@(^TMP("XQORS",$J,XQORS,"REF")_"0)"),X=$P(X0,"^",6) I $L(X),'$D(^XUSEC(X,DUZ)) W !!,"This option "_$P(X0,"^")_" is locked.",! D READ S Y=-1 Q 45 S ORNSV=$P(X0,"^",9),X="NOW",%DT="T" D ^%DT S X=$P(Y,".",2) I X>$P(ORNSV,"-"),X<$P(ORNSV,"-",2) W !!,"Not Available: ",ORNSV,! K ORNSV D READ S Y=-1 Q 46 K ORNSV I "QMOXALDT"'[$P(^TMP("XQORS",$J,XQORS,"FLG"),"^") W !!,"This option type not supported by 'unwinder' routines.",! D READ S Y=-1 Q 47 S Y=1 Q -
WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUP.m
r613 r623 1 XUP ;SFISC/RWF - Setup enviroment for programmers ;10/12/06 12:45 2 ;;8.0;KERNEL;**208,258,284,432**;Jul 10, 1995;Build 3 3 W !,"Setting up programmer environment" 4 S U="^",$ECODE="",$ETRAP="" ;Clear error and error trap 5 X ^%ZOSF("TYPE-AHEAD") 6 ;Check if Production and report 7 W !,"This is a "_$S($$PROD^XUPROD(1):"PRODUCTION",1:"TEST")_" account.",! 8 ; 9 K ^UTILITY($J),^XUTL("XQ",$J) D KILL1^XUSCLEAN 10 S U="^",DT=$$DT^XLFDT 11 S XUEOFF=^%ZOSF("EOFF"),XUEON=^%ZOSF("EON"),U="^",XUTT=0,XUIOP="" 12 D GETENV^%ZOSV S XUENV=Y,XUVOL=$P(Y,U,2),XUCI=$P(Y,U,1) 13 ;Reset DUZ if user "Switched Identities". 14 I $D(DUZ("SAV")) S DUZ=+DUZ("SAV"),DUZ(0)=$P(DUZ("SAV"),U,2) K DUZ("SAV") 15 ;Get user info 16 I $G(DUZ)>.5,$D(^VA(200,DUZ,0))[0 K DUZ W !,"DUZ Must point to a real user." G EXIT ;p432 17 I $G(DUZ)>0 D DUZ(DUZ) 18 I $G(DUZ)'>0!('$D(DUZ(0))) D ASKDUZ G:Y'>0 EXIT 19 I '$D(XQUSER) S XQUSER=$S($D(^VA(200,DUZ,20)):$P(^(20),"^",2),1:"Unk") 20 S DTIME=600 ;Set a temp DTIME 21 S DILOCKTM=+$G(^DD("DILOCKTM"),1) ;p432 22 ;Getting Terminal Type 23 ZIS I XUTT D ENQ^XUS1 G:$D(XUIOP(1)) ZIS2 S Y=0 D TT^XUS3 I Y>0 S XUIOP(1)=$P(XUIOP,";",2) G ZIS2 24 S X="`"_+$G(^VA(200,DUZ,1.2)),DIC="^%ZIS(2,",DIC(0)="MQ"_$S(X]"`0":"",1:"AE") D ^DIC G:Y'>0 EXIT 25 S XUIOP(1)=$P(Y,U,2) I DIC(0)["A",$G(^VA(200,+DUZ,0))]"" S $P(^VA(200,DUZ,1.2),U,1)=+Y 26 ZIS2 S %ZIS="L",IOP="HOME;"_XUIOP(1) D ^%ZIS G EXIT:POP W !,"Terminal Type set to: ",IOST,! 27 S DTIME=$$DTIME(DUZ,IOS),DUZ("BUF")=1,XUDEV=IOS 28 ;Save info, Set last sign-on 29 D SAVE^XUS1 S $P(^VA(200,DUZ,1.1),"^",1)=$$NOW^XLFDT 30 ;Check Mail 31 S Y=$P($G(^XMB(3.7,DUZ,0)),U,6) I Y W !,"You have "_Y_" new message"_$S(Y=1:"",1:"s")_"." 32 ;Setup error trap 33 I $$GET^XPAR("USR^SYS","XUS-XUP SET ERROR TRAP",1,"Q") S $ETRAP="D ERR^XUP" 34 D KILL1^XUSCLEAN S $P(XQXFLG,U,3)="XUP" D ^XQ1 35 EXIT ;Clean-up and exit 36 D KILL1^XUSCLEAN K XQY,XQY0 37 I $G(DUZ)>0,$$GET^XPAR("USR^SYS","XUS-XUP VPE",1,"Q"),$D(^%ZVEMS) X ^%ZVEMS ;Run VPE 38 Q 39 ; 40 ASKDUZ ;Ask for Access Code 41 N X 42 ;X XUEOFF S DIR(0)="FO",DIR("A")="Access Code" D ^DIR W ! X XUEON I $D(DIRUT) S Y=-1 Q 43 X XUEOFF W !,"Access Code: " S X=$$ACCEPT^XUS() X XUEON 44 I X["^"!('$L(X)) S Y=-1 Q 45 S X=$$UP^XLFSTR(X) S:X[":" XUTT=1,X=$P(X,":",1)_$P(X,":",2) 46 D ^XUSHSH S Y=$O(^VA(200,"A",X,0)) 47 K DUZ D DUZ(+Y) 48 Q 49 ; 50 DUZ(DA) ;Build DUZ for a user. Used by Mailman. 51 ;(p284) Make the setting of several DUZ parts conditional. 52 N Y 53 S Y(0)=$G(^VA(200,+DA,0)),Y("XUS")=$G(^XTV(8989.3,1,"XUS")) 54 S DUZ=DA 55 S:$G(DUZ(0))'="@" DUZ(0)=$P(Y(0),"^",4) 56 S DUZ(1)="",DUZ("AG")=$P($G(^XTV(8989.3,1,0)),"^",8) 57 S:'$G(DUZ(2)) DUZ(2)=$O(^VA(200,DUZ,2,0)) 58 S:'DUZ(2) DUZ(2)=+$P(Y("XUS"),"^",17) 59 S:'$L($G(DUZ("LANG"))) DUZ("LANG")=$P(Y("XUS"),"^",7) 60 Q 61 ; 62 DTIME(E,D) ;Return DTIME value for user E, device D. 63 N P 64 S P=$P($G(^VA(200,+$G(E),200)),"^",10) S:P="" P=$P($G(^%ZIS(1,+$G(D),"XUS")),"^",10) S:P="" P=$P($G(^XTV(8989.3,1,"XUS")),"^",10) 65 Q $S(P]"":P,1:300) 66 ; 67 ERR ; 68 N %XUP U $P 69 W !,"$ECODE=",$ECODE," $STACK=",$STACK 70 W !,"Location: ",$STACK($STACK-1,"PLACE") 71 R !!,"Want to record the error: No// ",%XUP:600 I "Yy"[$E(%XUP_"N") D ^%ZTER 72 D UNWIND^%ZTER ;S:'$ESTACK $ECODE="" S $ETRAP="" Q:$QUIT "" Q 1 XUP ;SFISC/RWF - Setup enviroment for programmers ;09/21/2004 16:35 2 ;;8.0;KERNEL;**208,258,284**;Jul 10, 1995 3 W !,"Setting up programmer environment" 4 N $ESTACK,$ETRAP S $ECODE="",$ETRAP="" ;Clear and error trap 5 X ^%ZOSF("TYPE-AHEAD") 6 ;Check if Production and report 7 W !,"This is a "_$S($$PROD^XUPROD(1):"PRODUCTION",1:"TEST")_" account.",! 8 ; 9 K ^UTILITY($J),^XUTL("XQ",$J) D KILL1^XUSCLEAN 10 S U="^",DT=$$DT^XLFDT 11 S XUEOFF=^%ZOSF("EOFF"),XUEON=^%ZOSF("EON"),U="^",XUTT=0,XUIOP="" 12 D GETENV^%ZOSV S XUENV=Y,XUVOL=$P(Y,U,2),XUCI=$P(Y,U,1) 13 ;Reset DUZ if user "Switched Identities". 14 I $D(DUZ("SAV")) S DUZ=+DUZ("SAV"),DUZ(0)=$P(DUZ("SAV"),U,2) K DUZ("SAV") 15 ;Get user info 16 I $G(DUZ)>0 D DUZ(DUZ) 17 I $G(DUZ)'>0!('$D(DUZ(0))) D ASKDUZ G:Y'>0 EXIT 18 I '$D(XQUSER) S XQUSER=$S($D(^VA(200,DUZ,20)):$P(^(20),"^",2),1:"Unk") 19 S DTIME=600 ;Set a temp DTIME 20 ;Getting Terminal Type 21 ZIS I XUTT D ENQ^XUS1 G:$D(XUIOP(1)) ZIS2 S Y=0 D TT^XUS3 I Y>0 S XUIOP(1)=$P(XUIOP,";",2) G ZIS2 22 S X="`"_+$G(^VA(200,DUZ,1.2)),DIC="^%ZIS(2,",DIC(0)="MQ"_$S(X]"`0":"",1:"AE") D ^DIC G:Y'>0 EXIT 23 S XUIOP(1)=$P(Y,U,2) I DIC(0)["A",$G(^VA(200,+DUZ,0))]"" S $P(^VA(200,DUZ,1.2),U,1)=+Y 24 ZIS2 S %ZIS="L",IOP="HOME;"_XUIOP(1) D ^%ZIS G EXIT:POP W !,"Terminal Type set to: ",IOST,! 25 S DTIME=$$DTIME(DUZ,IOS),DUZ("BUF")=1,XUDEV=IOS 26 ;Save info, Set last sign-on 27 D SAVE^XUS1 S $P(^VA(200,DUZ,1.1),"^",1)=$$NOW^XLFDT 28 ;Check Mail 29 S Y=$P($G(^XMB(3.7,DUZ,0)),U,6) I Y W !,"You have "_Y_" new message"_$S(Y=1:"",1:"s")_"." 30 ;Setup error trap 31 I $$GET^XPAR("USR^SYS","XUS-XUP SET ERROR TRAP",1,"Q") S $ETRAP="D ERR^XUP" 32 D KILL1^XUSCLEAN S $P(XQXFLG,U,3)="XUP" D ^XQ1 33 EXIT D KILL1^XUSCLEAN K XQY,XQY0 34 I $$GET^XPAR("USR^SYS","XUS-XUP VPE",1,"Q"),$D(^%ZVEMS) X ^%ZVEMS ;Run VPE 35 Q 36 ; 37 ASKDUZ X XUEOFF S DIR(0)="FO",DIR("A")="Access Code" D ^DIR W ! X XUEON I $D(DIRUT) S Y=-1 Q 38 S X=$$UP^XLFSTR(X) S:X[":" XUTT=1,X=$P(X,":",1)_$P(X,":",2) 39 D ^XUSHSH S Y=$O(^VA(200,"A",X,0)) 40 K DUZ D DUZ(+Y) Q 41 ; 42 DUZ(DA) ;Build DUZ for a user. Used by Mailman. 43 ;(p284) Make the setting of several DUZ parts conditional. 44 N Y S Y(0)=$G(^VA(200,+DA,0)),Y("XUS")=$G(^XTV(8989.3,1,"XUS")) 45 S DUZ=DA 46 S:$G(DUZ(0))'="@" DUZ(0)=$P(Y(0),"^",4) 47 S DUZ(1)="",DUZ("AG")=$P($G(^XTV(8989.3,1,0)),"^",8) 48 S:'$G(DUZ(2)) DUZ(2)=$O(^VA(200,DUZ,2,0)) 49 S:'DUZ(2) DUZ(2)=+$P(Y("XUS"),U,17) 50 S:'$L($G(DUZ("LANG"))) DUZ("LANG")=$P(Y("XUS"),U,7) 51 Q 52 ; 53 DTIME(E,D) ;Return DTIME value for user E, device D. 54 N P S P=$P($G(^VA(200,+$G(E),200)),"^",10) S:P="" P=$P($G(^%ZIS(1,+$G(D),"XUS")),"^",10) S:P="" P=$P($G(^XTV(8989.3,1,"XUS")),"^",10) 55 Q $S(P]"":P,1:300) 56 ; 57 ERR ; 58 U $P 59 W !,"$ECODE=",$ECODE," $STACK=",$STACK 60 R !!,"Want to record the error: No// ",%XUP:600 I "Yy"[$E(%XUP_"N") D ^%ZTER 61 D UNWIND^%ZTER ;S:'$ESTACK $ECODE="" S $ETRAP="" Q:$QUIT "" Q 62 ; -
WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUPROD.m
r613 r623 1 XUPROD ;ISF/RWF - Is this a PROD account. ;8/23/07 16:47 2 ;;8.0;KERNEL;**284,440**;Jul 10, 1995;Build 13 3 ; 4 ;IA# 4440 5 PROD(FORCE) ;Return 1 if this is a production account 6 ;A non-zero flag will force a real check 7 ;This call just checks a flag in the KSP, Other code will compair 8 ;with registered ID. 9 N LC,SID 10 S SID=$G(^XTV(8989.3,1,"SID")) 11 I '$L($P(SID,"^",3))!($P(SID,"^",3)'=$G(DT))!$G(FORCE) D 12 . D CHECK S SID=$G(^XTV(8989.3,1,"SID")) 13 Q +$P(SID,"^",1) 14 ; 15 CHECK ;Check if SID matched stored value, Set field 501 16 N CSID,SSID,FDA 17 L +^XTV(8989.3,1,"SID"):2 18 S CSID=$$SID^%ZOSV,SSID=$P($G(^XTV(8989.3,1,"SID")),"^",2) 19 S FDA(8989.3,"1,",501)=(CSID=SSID),FDA(8989.3,"1,",503)=$$DT^XLFDT 20 D FILE^DIE("","FDA") 21 L -^XTV(8989.3,1,"SID") 22 Q 23 ; 24 SSID(SID) ;Set the SID into KSP. 25 N FDA 26 S FDA(8989.3,"1,",502)=SID,FDA(8989.3,"1,",503)="@" 27 L +^XTV(8989.3,1,"SID"):2 28 D FILE^DIE("","FDA") 29 L -^XTV(8989.3,1,"SID") 30 Q 31 ASK ;Ask user if this is prod. 32 N DIR,P S P=$$PROD 33 S DIR(0)="YO",DIR("A")="Is this a Production Account",DIR("B")="No" 34 S DIR("A",1)="" 35 S DIR("A",2)="This is now a "_$S(P:"PRODUCTION",1:"TEST")_" account." 36 S DIR("A",3)=" " 37 S DIR("A",4)="Only answer YES if this is the full time Production Account." 38 S DIR("A",5)="Answer No for all other accounts." 39 D ^DIR Q:$D(DIRUT) 40 I Y=1 D SSID($$SID^%ZOSV) 41 E D SSID("2~TEST~999") 42 S P=$$PROD 43 W:P !!,"This is now a PRODUCTION account.",! W:'P !!,"This is now a TEST account.",! 44 Q 45 ; 46 EDIT ;Edit Logical - Physical fields 47 N DIE,DA,DR 48 W !!,"This is only valid in a Cache v5.2 client/server configuration." 49 W !,"This lets you edit the fields that support the" 50 W !,"LOGICAL to PHYSICAL translation for the System ID.",!! 51 S DA=1,DIE="^XTV(8989.3,",DR="504;505" D ^DIE 52 Q 1 XUPROD ;ISF/RWF - Is this a PROD account. ;06/17/2004 08:13 2 ;;8.0;KERNEL;**284**;Jul 10, 1995 3 ; 4 ;IA# 4440 5 PROD(FORCE) ;Return 1 if this is a production account 6 ;A non-zero flag will force a real check 7 ;This call just checks a flag in the KSP, Other code will compair 8 ;with registered ID. 9 N LC,SID 10 S SID=$G(^XTV(8989.3,1,"SID")) 11 I '$L($P(SID,"^",3))!($P(SID,"^",3)'=$G(DT))!$G(FORCE) D 12 . D CHECK S SID=$G(^XTV(8989.3,1,"SID")) 13 Q +$P(SID,"^",1) 14 ; 15 CHECK ;Check if SID matched stored value, Set field 501 16 N CSID,SSID,FDA 17 L +^XTV(8989.3,1,"SID"):2 18 S CSID=$$SID^%ZOSV,SSID=$P($G(^XTV(8989.3,1,"SID")),"^",2) 19 S FDA(8989.3,"1,",501)=(CSID=SSID),FDA(8989.3,"1,",503)=$$DT^XLFDT 20 D FILE^DIE("","FDA") 21 L -^XTV(8989.3,1,"SID") 22 Q 23 ; 24 SSID(SID) ;Set the SID into KSP. 25 N FDA 26 S FDA(8989.3,"1,",502)=SID,FDA(8989.3,"1,",503)="@" 27 L +^XTV(8989.3,1,"SID"):2 28 D FILE^DIE("","FDA") 29 L -^XTV(8989.3,1,"SID") 30 Q 31 ASK ;Ask user if this is prod. 32 N DIR,P S P=$$PROD 33 S DIR(0)="YO",DIR("A")="Is this a Production Account",DIR("B")="No" 34 S DIR("A",1)="This is now a "_$S(P:"PRODUCTION",1:"TEST")_" account." 35 S DIR("A",2)=" " 36 S DIR("A",3)="Only answer YES if this is the full time Production Account." 37 S DIR("A",4)="Answer No for all other accounts." 38 D ^DIR Q:$D(DIRUT) 39 I Y=1 D SSID($$SID^%ZOSV) 40 E D SSID("2~TEST~999") 41 S P=$$PROD 42 W:P !!,"This is now a PRODUCTION account.",! W:'P !!,"This is now a TEST account.",! 43 Q -
WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUS.m
r613 r623 1 XUS ;SFISC/STAFF - SIGNON ;1:27 PM 11 Dec 2008 2 ;;8.0;KERNEL;**16,26,49,59,149,180,265,337,419,434,437**;Jul 10, 1995;Build 23 3 ; Modified from FOIA VISTA, 4 ; Copyright (C) 2007 WorldVistA 5 ; 6 ; This program is free software; you can redistribute it and/or modify 7 ; it under the terms of the GNU General Public License as published by 8 ; the Free Software Foundation; either version 2 of the License, or 9 ; (at your option) any later version. 10 ; 11 ; This program is distributed in the hope that it will be useful, 12 ; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 ; GNU General Public License for more details. 15 ; 16 ; You should have received a copy of the GNU General Public License 17 ; along with this program; if not, write to the Free Software 18 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 19 ; 20 ;Sign-on message numbers are 30810.51 to 30810.99 21 S U="^" D INTRO^XUS1A() 22 K K ^XUTL("ZISPARAM",$I) 23 S U="^",XQXFLG("GUI")="^" 24 W ! S $Y=0 D SET1(1) I POP S XUM=3 G NO ;Sets DUZ("LANG") 25 S XUSTMP(51)=$$EZBLD^DIALOG(30810.51),XUSTMP(52)=$$EZBLD^DIALOG(30810.52) 26 W !!,"Volume set: ",$P(XUENV,U,4)," UCI: ",XUCI," Device: ",$I W:$S('$D(IO("ZIO")):0,1:$I'=IO("ZIO")) " (",IO("ZIO"),")" W ! 27 RESTART ; 28 S XUM=$$SET2 G:XUM NO 29 I $P(XU1,U,2)]"" S XUM=$$DEVPAS() I XUM G H:XUM<0,NO 30 ;S PGM=$P(XOPT,U,8),XUA=$P(PGM,"[",1) I XUA]"" X XUEON G NEXT^XUS1 31 A S (XUSER(0),XUSER(1),XQUR)="" 32 ;Check for locked IP/device. 33 I $$LKCHECK^XUSTZIP() S XUM=7,XUFAC=$P(XOPT,U,2),XUHALT=1 G NO 34 ;Auto Sign-on check 35 S X=$$AUTOXUS^XUS1B() I X>0 S DUZ=X D USER(DUZ) W !!,">> Auto Sign-on: ",$P(XUSER(0),U)," <<<",! G B 36 X XUEOFF S AV=$$ASKAV() X XUEON I AV="^;^" G H ;Get out 37 I AV["MAIL-BOX",AV[";XMR" S (XUA,PGM)="XMR",XMCHAN=$P($P(AV,";")," ",2),DUZ=.5 G XMR^XUSCLEAN 38 S XQUR=$P(AV,";",3) 39 S DUZ=$$CHECKAV(AV) K AV 40 S XUM=$$UVALID() G:XUM NO 41 B K XUF,%1 S XUF=0 X XUEON 42 I DUZ D USER^XUS1 G:XUM NO 43 I DUZ D SEC^XUS3:($D(^%ZIS(1,XUDEV,"TIME"))!$D(^(95))) G:XUM NO 44 G NO:'DUZ 45 S DTIME=$P(XOPT,U,10),X=$S(DUZ("BUF"):"",1:"NO-")_"TYPE-AHEAD" X:$D(^%ZOSF(X)) ^(X) 46 D TT^XUS3:$G(XUTT) 47 D CLRFAC^XUS3($G(IO("IP"))) 48 PGM ; 49 S Y=+$G(^%ZIS(1,XUDEV,201)) I Y>0,$$CHK S XQY=Y G OK 50 S Y=+$G(^VA(200,DUZ,201)) I Y>0,$$CHK S XQY=Y G OK 51 I $D(DUZ("ASH")) S Y=$O(^DIC(19,"B","XU NOP MENU",0)) I Y>0 S XQY=Y G OK ;rwf 403 52 S XUM=16 53 G NO 54 ; 55 OK D CHEK^XQ83 56 S (XUA,PGM)="XQ" 57 G NEXT^XUS1 58 ; 59 CHK() ;Check that option exeist and LOCK 60 I $D(^DIC(19,Y,0)),$S($P(^(0),U,6)="":1,1:$D(^XUSEC($P(^(0),U,6),DUZ))) Q 1 61 Q 0 62 ; 63 LC S X=$$UP(X) 64 Q 65 UP(%) Q $TR(%,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") 66 ; 67 FAC ;Failed access 68 S:'DUZ XUF(.1)=$E(%1) 69 S:XUF=2 XUF(.2)=XUF(.2)+1,XUF(XUF(.2))=%1 S %1="" Q 70 Q 71 NO ;Tell why didn't get on 72 S X=$$NO^XUS3() G RESTART:'X ;fall into exit 73 H ;Exit point for all applications 74 C ;CLOSE 75 G ^XUSCLEAN 76 ; 77 ON X ^%ZOSF("EON") Q 78 ; 79 ASKAV(PRE) ;Ask and return Access;Verify code, Turn off echo before calling 80 N X,Y S PRE=$G(PRE) 81 F W !,PRE,XUSTMP(51) S X=$$ACCEPT S:X="^" X="^;^" Q:$L(X) 82 S X=$TR(X,$C(9),";") ;Convert TAB to ; to match GUI. 83 I $P(X," ")="MAIL-BOX" S X=X_";XMR" 84 I $E(X,1,7)="~~TOK~~" Q X ;Use CCOW token 85 I '$L($P(X,";",2)) W !,PRE,XUSTMP(52) S Y=$$ACCEPT S:Y="^" X="^;" S $P(X,";",2)=Y 86 Q X 87 ; 88 ;Timeout used by XUSTZ call. 89 ACCEPT(TO) ;Read A/V and echo '*' char. 90 ;Have the Read write to flush the buffer on some systems 91 N C,A,E K DUOUT S A="",TO=$G(TO,60),E=0 92 F D Q:E 93 . R "",*C:TO S:('$T) DUOUT=1 S:('$T)!(C=94) A="^" 94 . I (A="^")!(C=13)!($L(A)>60) S E=1 Q 95 . I C=127 Q:'$L(A) S A=$E(A,1,$L(A)-1) W $C(8,32,8) Q 96 . S A=A_$C(C) W *42 97 . Q 98 Q A 99 ; 100 CHECKAV(X1) ;Check A/V code return DUZ or Zero. (Called from XUSRB) 101 N %,%1,X,Y,IEN,DA,DIK 102 S IEN=0 103 ;Start CCOW 104 I $E(X1,1,7)="~~TOK~~" D Q:IEN>0 IEN 105 . I $E(X1,8,9)="~1" S IEN=$$CHKASH^XUSRB4($E(X1,8,255)) 106 . I $E(X1,8,9)="~2" S IEN=$$CHKCCOW^XUSRB4($E(X1,8,255)) 107 . Q 108 ;End CCOW 109 ; WV p437 ;Allow case sensitivefor VOE 110 S X1=$S($$GET^XPAR("SYS","XU VC CASE SENSITIVE"):$$UP($P(X1,";",1))_";"_$P(X1,";",2),1:$$UP(X1)) 111 ; End WV change 112 S X1=$$UP(X1) S:X1[":" XUTT=1,X1=$TR(X1,":") 113 S X=$P(X1,";") Q:X="^" -1 S:XUF %1="Access: "_X 114 Q:X'?1.20ANP 0 115 S X=$$EN^XUSHSH(X) I '$D(^VA(200,"A",X)) D LBAV Q 0 116 S %1="",IEN=$O(^VA(200,"A",X,0)),XUF(.3)=IEN D USER(IEN) 117 S X=$P(X1,";",2) S:XUF %1="Verify: "_X S X=$$EN^XUSHSH(X) 118 I $P(XUSER(1),"^",2)'=X D LBAV Q 0 119 I $G(XUFAC(1)) S DIK="^XUSEC(4,",DA=XUFAC(1) D ^DIK 120 Q IEN 121 LBAV ;Log Bad AV 122 D:XUF FAC 123 I IEN S X=$P($G(^VA(200,IEN,1.1)),U,2)+1,$P(^(1.1),"^",2)=X 124 Q 125 ; 126 USER(IX) ;Build XUSER 127 S XUSER(0)=$G(^VA(200,+IX,0)),XUSER(1)=$G(^(.1)),XUSER(1.1)=$G(^(1.1)) 128 Q 129 ; 130 XUVOL ;Setup XUENV, XUCI,XQVOL,XUVOL 131 S U="^" D GETENV^%ZOSV S XUENV=Y,XUCI=$P(Y,U,1),XQVOL=$P(Y,U,2) 132 S X=$O(^XTV(8989.3,1,4,"B",XQVOL,0)),XUVOL=$S(X>0:^XTV(8989.3,1,4,X,0),1:XQVOL_"^y^1") 133 Q 134 ; 135 XOPT ;Setup initial XOPT 136 S XOPT=$S($D(^XTV(8989.3,1,"XUS")):^("XUS"),1:"") 137 F I=2:1:15 I $P(XOPT,U,I)="" S $P(XOPT,U,I)=$P("^5^900^1^1^^^^1^300^^^^N^90",U,I) 138 Q 139 ; 140 SET1(FLAG) ;Setup parameters (also called from XUSRB) 141 N % 142 S U="^",XUEON=^%ZOSF("EON"),XUEOFF=^("EOFF") 143 D XUVOL,XOPT S DUZ("LANG")=$P(XOPT,U,7) ;S:$P(XUVOL,U,6)="y" XRTL=XUCI_","_XQVOL 144 K ^XUTL("XQ",$J) S XUF=0,XUDEV=0,DUZ=0,DUZ(0)="@",IOS=0,ION="" 145 I FLAG S %ZIS="L",IOP="HOME" D ^%ZIS Q:POP 146 S XUDEV=IOS,XUIOP=ION 147 D GETFAC^XUS3($G(IO("IP"))) 148 S %=$P(XOPT,U,14) 149 I "N"'[% D 150 . S XUF=(%["R")+1,XUF(.1)="",XUF(.2)=0,XUF(.3)=0 151 . I %["D" S:$D(^XTV(8989.3,1,4.33,"B",XUDEV))[0 XUF=0 152 S DILOCKTM=+$G(^DD("DILOCKTM"),1) ;p434 IA#4909 153 Q 154 SET2() ;EF. Return error code (also called from XUSRB) 155 N %,X 156 S XUNOW=$$HTFM^XLFDT($H),DT=$P(XUNOW,".") 157 K DUZ,XUSER 158 S (DUZ,DUZ(2))=0,(DUZ(0),DUZ("AG"),XUSER(0),XUSER(1),XUTT,%UCI)="" 159 S %=$$INHIBIT^XUSRB() I %>0 Q % 160 S X=$G(^%ZIS(1,XUDEV,"XUS")),XU1=$G(^(1)) 161 I $L(X) F I=1:1:15 I $L($P(X,U,I)) S $P(XOPT,U,I)=$P(X,U,I) 162 S DTIME=600 163 I '$P(XOPT,U,11),$D(^%ZIS(1,XUDEV,90)),^(90)>2800000,^(90)'>DT Q 8 164 Q 0 165 ; 166 UVALID() ;EF. Is it valid for this user to sign on? 167 I DUZ'>0 Q 4 168 I $P(XUSER(1.1),U,5),$P(XUSER(1.1),U,5)>XUNOW S XUM(0)=$$FMTE^XLFDT($P(XUSER(1.1),U,5),"2PM") Q 18 ;User locked until 169 I $P(XUSER(0),U,11),$P(XUSER(0),U,11)'>DT Q 11 ;Access Terminated 170 I $D(DUZ("ASH")) Q 0 ;If auto handle, Allow to sign-on p434 171 I $P(XUSER(0),U,7) Q 5 ;Disuser flag set 172 I '$L($P(XUSER(1),U,2)) Q 21 ;p419, p434 173 Q 0 174 ; 175 DEVPAS() ;EF. Ask device password 176 X XUEOFF W !,"DEVICE PASSWORD: " R X:60 X XUEON 177 S X=$E(X,1,30) S:'$T X="^" D LC Q:X["^" -1 I $P(XU1,U,2)'=X S:XUF %1="Device: "_X D:XUF FAC Q 6 178 Q 0 179 ; 1 XUS ;SFISC/STAFF - SIGNON ;3/19/07 09:15 2 ;;8.0;KERNEL;**16,26,49,59,149,180,265,337,419,437**;Jul 10, 1995;Build 22 3 ; Modified from FOIA VISTA, 4 ; Copyright (C) 2007 WorldVistA 5 ; 6 ; This program is free software; you can redistribute it and/or modify 7 ; it under the terms of the GNU General Public License as published by 8 ; the Free Software Foundation; either version 2 of the License, or 9 ; (at your option) any later version. 10 ; 11 ; This program is distributed in the hope that it will be useful, 12 ; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 ; GNU General Public License for more details. 15 ; 16 ; You should have received a copy of the GNU General Public License 17 ; along with this program; if not, write to the Free Software 18 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA 19 ;Sign-on message numbers are 30810.51 to 30810.99 20 S U="^" D INTRO^XUS1A() 21 K K ^XUTL("ZISPARAM",$I) 22 S U="^",XQXFLG("GUI")="^" 23 W ! S $Y=0 D SET1(1) I POP S XUM=3 G NO ;Sets DUZ("LANG") 24 S XUSTMP(51)=$$EZBLD^DIALOG(30810.51),XUSTMP(52)=$$EZBLD^DIALOG(30810.52) 25 W !!,"Volume set: ",$P(XUENV,U,4)," UCI: ",XUCI," Device: ",$I W:$S('$D(IO("ZIO")):0,1:$I'=IO("ZIO")) " (",IO("ZIO"),")" W ! 26 RESTART ; 27 S XUM=$$SET2 G:XUM NO 28 I $P(XU1,U,2)]"" S XUM=$$DEVPAS() I XUM G H:XUM<0,NO 29 ;S PGM=$P(XOPT,U,8),XUA=$P(PGM,"[",1) I XUA]"" X XUEON G NEXT^XUS1 30 A S (XUSER(0),XUSER(1),XQUR)="" 31 ;Check for locked IP/device. 32 I $$LKCHECK^XUSTZIP() S XUM=7,XUFAC=$P(XOPT,U,2),XUHALT=1 G NO 33 ;Auto Sign-on check 34 S X=$$AUTOXUS^XUS1B() I X>0 S DUZ=X D USER(DUZ) W !!,">> Auto Sign-on: ",$P(XUSER(0),U)," <<<",! G B 35 X XUEOFF S AV=$$ASKAV() X XUEON I AV="^;^" G H ;Get out 36 I AV["MAIL-BOX",AV[";XMR" S (XUA,PGM)="XMR",XMCHAN=$P($P(AV,";")," ",2),DUZ=.5 G XMR^XUSCLEAN 37 S XQUR=$P(AV,";",3) 38 S DUZ=$$CHECKAV(AV) K AV 39 S XUM=$$UVALID() G:XUM NO 40 B K XUF,%1 S XUF=0 X XUEON 41 I DUZ D USER^XUS1 G:XUM NO 42 I DUZ D SEC^XUS3:($D(^%ZIS(1,XUDEV,"TIME"))!$D(^(95))) G:XUM NO 43 G NO:'DUZ 44 S DTIME=$P(XOPT,U,10),X=$S(DUZ("BUF"):"",1:"NO-")_"TYPE-AHEAD" X:$D(^%ZOSF(X)) ^(X) 45 D TT^XUS3:$G(XUTT) 46 D CLRFAC^XUS3($G(IO("IP"))) 47 PGM ; 48 S Y=+$G(^%ZIS(1,XUDEV,201)) I Y>0,$$CHK S XQY=Y G OK 49 S Y=+$G(^VA(200,DUZ,201)) I Y>0,$$CHK S XQY=Y G OK 50 I $D(DUZ("ASH")) S Y=$O(^DIC(19,"B","XU NOP MENU",0)) I Y>0 S XQY=Y G OK ;rwf 403 51 S XUM=16 52 G NO 53 ; 54 OK D CHEK^XQ83 55 S (XUA,PGM)="XQ" 56 G NEXT^XUS1 57 ; 58 CHK() ;Check that option exeist and LOCK 59 I $D(^DIC(19,Y,0)),$S($P(^(0),U,6)="":1,1:$D(^XUSEC($P(^(0),U,6),DUZ))) Q 1 60 Q 0 61 ; 62 LC S X=$$UP(X) 63 Q 64 UP(%) Q $TR(%,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") 65 ; 66 FAC ;Failed access 67 S:'DUZ XUF(.1)=$E(%1) 68 S:XUF=2 XUF(.2)=XUF(.2)+1,XUF(XUF(.2))=%1 S %1="" Q 69 Q 70 NO ;Tell why didn't get on 71 S X=$$NO^XUS3() G RESTART:'X ;fall into exit 72 H ;Exit point for all applications 73 C ;CLOSE 74 G ^XUSCLEAN 75 ; 76 ON X ^%ZOSF("EON") Q 77 ; 78 ASKAV(PRE) ;Ask and return Access;Verify code, Turn off echo before calling 79 N X,Y S PRE=$G(PRE) 80 F W !,PRE,XUSTMP(51) S X=$$ACCEPT S:X="^" X="^;^" Q:$L(X) 81 S X=$TR(X,$C(9),";") ;Convert TAB to ; to match GUI. 82 I $P(X," ")="MAIL-BOX" S X=X_";XMR" 83 I $E(X,1,7)="~~TOK~~" Q X ;Use CCOW token 84 I '$L($P(X,";",2)) W !,PRE,XUSTMP(52) S Y=$$ACCEPT S:Y="^" X="^;" S $P(X,";",2)=Y 85 Q X 86 ; 87 ;Timeout used by XUSTZ call. 88 ACCEPT(TO) ;Read A/V and echo '*' char. 89 ;Have the Read write to flush the buffer on some systems 90 N C,A,E K DUOUT S A="",TO=$G(TO,60),E=0 91 F D Q:E 92 . R "",*C:TO S:('$T) DUOUT=1 S:('$T)!(C=94) A="^" 93 . I (A="^")!(C=13)!($L(A)>60) S E=1 Q 94 . I C=127 Q:'$L(A) S A=$E(A,1,$L(A)-1) W $C(8,32,8) Q 95 . S A=A_$C(C) W *42 96 . Q 97 Q A 98 ; 99 CHECKAV(X1) ;Check A/V code return DUZ or Zero. (Called from XUSRB) 100 N %,%1,X,Y,IEN,DA,DIK 101 S IEN=0 102 ;Start CCOW 103 I $E(X1,1,7)="~~TOK~~" D Q:IEN>0 IEN 104 . I $E(X1,8,9)="~1" S IEN=$$CHKASH^XUSRB4($E(X1,8,255)) 105 . I $E(X1,8,9)="~2" S IEN=$$CHKCCOW^XUSRB4($E(X1,8,255)) 106 . Q 107 ;End CCOW 108 S X1=$S($$GET^XPAR("SYS","XU VC CASE SENSITIVE"):$$UP($P(X1,";",1))_";"_$P(X1,";",2),1:$$UP(X1)) S:X1[":" XUTT=1,X1=$TR(X1,":") ; Allow case sensitive for VOE 109 S X=$P(X1,";") Q:X="^" -1 S:XUF %1="Access: "_X 110 Q:X'?1.20ANP 0 111 S X=$$EN^XUSHSH(X) I '$D(^VA(200,"A",X)) D LBAV Q 0 ; Case insensitive for Access Code for VOE 112 S %1="",IEN=$O(^VA(200,"A",X,0)),XUF(.3)=IEN D USER(IEN) 113 S X=$P(X1,";",2) S:XUF %1="Verify: "_X S X=$$EN^XUSHSH(X) 114 I $P(XUSER(1),"^",2)'=X D LBAV Q 0 115 I $G(XUFAC(1)) S DIK="^XUSEC(4,",DA=XUFAC(1) D ^DIK 116 Q IEN 117 LBAV ;Log Bad AV 118 D:XUF FAC 119 I IEN S X=$P($G(^VA(200,IEN,1.1)),U,2)+1,$P(^(1.1),"^",2)=X 120 Q 121 ; 122 USER(IX) ;Build XUSER 123 S XUSER(0)=$G(^VA(200,+IX,0)),XUSER(1)=$G(^(.1)),XUSER(1.1)=$G(^(1.1)) 124 Q 125 ; 126 XUVOL ;Setup XUENV, XUCI,XQVOL,XUVOL 127 S U="^" D GETENV^%ZOSV S XUENV=Y,XUCI=$P(Y,U,1),XQVOL=$P(Y,U,2) 128 S X=$O(^XTV(8989.3,1,4,"B",XQVOL,0)),XUVOL=$S(X>0:^XTV(8989.3,1,4,X,0),1:XQVOL_"^y^1") 129 Q 130 ; 131 XOPT ;Setup initial XOPT 132 S XOPT=$S($D(^XTV(8989.3,1,"XUS")):^("XUS"),1:"") 133 F I=2:1:15 I $P(XOPT,U,I)="" S $P(XOPT,U,I)=$P("^5^900^1^1^^^^1^300^^^^N^90",U,I) 134 Q 135 ; 136 SET1(FLAG) ;Setup parameters (also called from XUSRB) 137 N % 138 S U="^",XUEON=^%ZOSF("EON"),XUEOFF=^("EOFF") 139 D XUVOL,XOPT S DUZ("LANG")=$P(XOPT,U,7) S:$P(XUVOL,U,6)="y" XRTL=XUCI_","_XQVOL 140 K ^XUTL("XQ",$J) S XUF=0,XUDEV=0,DUZ=0,DUZ(0)="@",IOS=0,ION="" 141 I FLAG S %ZIS="L",IOP="HOME" D ^%ZIS Q:POP 142 S XUDEV=IOS,XUIOP=ION D:$D(XRTL) T0^%ZOSV 143 D GETFAC^XUS3($G(IO("IP"))) 144 S %=$P(XOPT,U,14) 145 I "N"'[% D 146 . S XUF=(%["R")+1,XUF(.1)="",XUF(.2)=0,XUF(.3)=0 147 . I %["D" S:$D(^XTV(8989.3,1,4.33,"B",XUDEV))[0 XUF=0 148 Q 149 SET2() ;EF. Return error code (also called from XUSRB) 150 N %,X 151 S XUNOW=$$HTFM^XLFDT($H),DT=$P(XUNOW,".") 152 K DUZ,XUSER 153 S (DUZ,DUZ(2))=0,(DUZ(0),DUZ("AG"),XUSER(0),XUSER(1),XUTT,%UCI)="" 154 S %=$$INHIBIT^XUSRB() I %>0 Q % 155 S X=$G(^%ZIS(1,XUDEV,"XUS")),XU1=$G(^(1)) 156 I $L(X) F I=1:1:15 I $L($P(X,U,I)) S $P(XOPT,U,I)=$P(X,U,I) 157 S DTIME=600 158 I '$P(XOPT,U,11),$D(^%ZIS(1,XUDEV,90)),^(90)>2800000,^(90)'>DT Q 8 159 I $D(XRT0) S XRTN="XUS" D T1^%ZOSV 160 Q 0 161 ; 162 UVALID() ;EF. Is it valid for this user to sign on? 163 I DUZ'>0 Q 4 164 I $P(XUSER(1.1),U,5),$P(XUSER(1.1),U,5)>XUNOW S XUM(0)=$$FMTE^XLFDT($P(XUSER(1.1),U,5),"2PM") Q 18 ;User locked until 165 I $P(XUSER(0),U,11),$P(XUSER(0),U,11)'>DT Q 11 ;Access Terminated 166 I $P(XUSER(0),U,7) Q 5 ;Disuser flag set 167 I '$L($P(XUSER(1),U,2)) Q 21 ;419 168 Q 0 169 ; 170 DEVPAS() ;EF. Ask device password 171 X XUEOFF W !,"DEVICE PASSWORD: " R X:60 X XUEON 172 S X=$E(X,1,30) S:'$T X="^" D LC Q:X["^" -1 I $P(XU1,U,2)'=X S:XUF %1="Device: "_X D:XUF FAC Q 6 173 Q 0 174 ; -
WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUS2.m
r613 r623 1 XUS2 2 ;;8.0;KERNEL;**59,180,313,419,437**;Jul 10, 1995;Build 23 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 ACCED 22 23 24 25 26 AC1 27 28 29 AASK 30 31 32 33 34 35 AASK1 36 37 38 39 40 41 42 43 44 45 REASK 46 47 48 49 50 AST(XUH) 51 52 53 54 55 56 57 58 59 60 GET 61 62 63 64 65 DIRUT 66 67 68 CLR 69 70 71 72 73 74 NEWCODE 75 76 77 CVC 78 79 80 81 82 VERED 83 84 85 86 87 VC1 88 89 90 91 VASK 92 93 VASK1 94 95 96 97 98 VCHK(S,EC) 99 100 101 102 103 104 105 106 107 108 109 110 111 VST(XUH,%) 112 113 114 115 116 117 118 119 DEL 120 121 122 123 AAUTO 124 125 126 127 128 AGEN 129 130 131 132 133 134 AHELP 135 136 137 138 VHELP 139 140 141 142 VAUTO 143 144 145 146 147 VGEN 148 149 150 151 152 YN 153 154 155 156 157 158 OUT 159 160 161 162 163 164 CHKCUR() 165 166 167 168 CHK1 169 170 171 172 173 174 BRCVC(XV1,XV2) 175 176 177 178 179 180 181 182 AVHLPTXT(%) 183 184 185 186 187 USER 188 EDIT 1 XUS2 ;SF/RWF - TO CHECK OR RETURN USER ATTRIBUTES ;2/3/07 19:18 2 ;;8.0;KERNEL;**59,180,313,419,437**;Jul 10, 1995;Build 22 3 Q 4 ; Modified from FOIA VISTA, 5 ; Copyright (C) 2007 WorldVistA 6 ; 7 ; This program is free software; you can redistribute it and/or modify 8 ; it under the terms of the GNU General Public License as published by 9 ; the Free Software Foundation; either version 2 of the License, or 10 ; (at your option) any later version. 11 ; 12 ; This program is distributed in the hope that it will be useful, 13 ; but WITHOUT ANY WARRANTY; without even the implied warranty of 14 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 ; GNU General Public License for more details. 16 ; 17 ; You should have received a copy of the GNU General Public License 18 ; along with this program; if not, write to the Free Software 19 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA 20 ; 21 ACCED ; ACCESS CODE EDIT from DD 22 I "Nn"[$E(X,1) S X="" Q 23 I "Yy"'[$E(X,1) K X Q 24 N DIR,DIR0,XUAUTO,XUK 25 S XUAUTO=($P($G(^XTV(8989.3,1,3)),U,1)="y"),XUH="" 26 AC1 D CLR,AAUTO:XUAUTO,AASK:'XUAUTO G OUT:$D(DIRUT) D REASK G OUT:$D(DIRUT),AC1:'XUK D CLR,AST(XUH) 27 G OUT 28 ; 29 AASK ;Ask for Access code 30 N X,XUU,XUEX X ^%ZOSF("EOFF") 31 S XUEX=0 32 F D AASK1 Q:XUEX!($D(DIRUT)) 33 Q 34 ; 35 AASK1 ; 36 W "Enter a new ACCESS CODE <Hidden>: " D GET Q:$D(DIRUT) 37 I X="@" D DEL D:Y'=1 DIRUT S XUH="",XUEX=1 Q 38 I X[$C(34)!(X[";")!(X["^")!(X[":")!(X'?.UNP)!($L(X)>20)!($L(X)<6)!(X="MAIL-BOX") D CLR W $C(7),$$AVHLPTXT(1) D AHELP Q 39 I 'XUAUTO,((X?6.20A)!(X?6.20N)) D CLR W $C(7),$$AVHLPTXT(1),! Q 40 S XUU=X,X=$$EN^XUSHSH(X),XUH=X,XMB(1)=$O(^VA(200,"A",XUH,0)) I XMB(1),XMB(1)'=DA S XMB="XUS ACCESS CODE VIOLATION",XMB(1)=$P(^VA(200,XMB(1),0),"^"),XMDUN="Security" D ^XMB 41 I $D(^VA(200,"AOLD",XUH))!$D(^VA(200,"A",XUH)) D CLR W $C(7),"This has been used previously as an ACCESS CODE.",! Q 42 S XUEX=1 ;Now we can quit 43 Q 44 ; 45 REASK S XUK=1 Q:XUH="" D CLR X ^%ZOSF("EOFF") 46 F XUK=3:-1:1 W "Please re-type the new code to show that I have it right: " D GET G:$D(DIRUT) DIRUT D ^XUSHSH Q:(XUH=X) D CLR W "This doesn't match. Try again!",!,$C(7) 47 S:XUH'=X XUK=0 48 Q 49 ; 50 AST(XUH) ;Change ACCESS CODE and index. 51 W "OK, Access code has been changed!" 52 N FDA,IEN,ERR 53 S IEN=DA_"," 54 S FDA(200,IEN,2)=XUH D FILE^DIE("","FDA","ERR") 55 W !,"The VERIFY CODE has been deleted as a security measure.",!,"You will need to enter a new VERIFY code so the user can sign-on.",$C(7) 56 D VST("",1) 57 I $D(^XMB(3.7,DA,0))[0 S Y=DA D NEW^XM ;Make sure has a Mailbox 58 Q 59 ; 60 GET ;Get the user input and convert case. 61 S X=$$ACCEPT^XUS I (X["^")!('$L(X)) D DIRUT 62 I '$D(ASKINGVC)!'$$GET^XPAR("SYS","XU VC CASE SENSITIVE") S X=$$UP^XLFSTR(X) ;for VOE allow case sensitive Verify Code 63 Q 64 ; 65 DIRUT S DIRUT=1 66 Q 67 ; 68 CLR ;New line or Clear screenman area 69 I '$D(DDS) W ! Q 70 N DX,DY 71 D CLRMSG^DDS S DX=0,DY=DDSHBX+1 X IOXY 72 Q 73 ; 74 NEWCODE D REASK I XUK W !,"OK, remember this code for next time!" 75 G OUT 76 ; 77 CVC ;From XUS1 78 N DA,X 79 S DA=DUZ,X="Y" 80 W !,"You must change your VERIFY CODE at this time." 81 ;Fall into next code 82 VERED ; VERIFY CODE EDIT From DD 83 N DIR,DIR0,XUAUTO,ASKINGVC 84 I "Nn"[$E(X,1) S X="" Q 85 I "Yy"'[$E(X,1) K X Q 86 S ASKINGVC=1,XUH="",XUAUTO=($P($G(^XTV(8989.3,1,3)),U,3)="y") S:DUZ=DA XUAUTO="n" ;Auto only for admin 87 VC1 D CLR,VASK:'XUAUTO,VAUTO:XUAUTO G OUT:$D(DIRUT) D REASK G OUT:$D(DIRUT),VC1:'XUK D CLR,VST(XUH,1) 88 D CALL^XUSERP(DA,2) 89 G OUT 90 ; 91 VASK ;Ask for Verify Code 92 N X,XUU X ^%ZOSF("EOFF") G:'$$CHKCUR() DIRUT D CLR 93 VASK1 W "Enter a new VERIFY CODE: " D GET Q:$D(DIRUT) 94 I '$D(XUNC),(X="@") D DEL G:Y'=1 DIRUT S XUH="" Q 95 D CLR S XUU=X,X=$$EN^XUSHSH(X),XUH=X,Y=$$VCHK(XUU,XUH) I +Y W $C(7),$P(Y,U,2,9),! D:+Y=1 VHELP G VASK1 96 Q 97 ; 98 VCHK(S,EC) ;Call with String and Encripted versions 99 ;Updated per VHA directive 6210 Strong Passwords 100 N PUNC,NA S PUNC="~`!@#$%&*()_-+=|\{}[]'<>,.?/" 101 S NA("FILE")=200,NA("FIELD")=.01,NA("IENS")=DA_",",NA=$$HLNAME^XLFNAME(.NA) 102 ; for VOE allow case sensitive Verify Code with S'?.ANP 103 I ($L(S)<8)!($L(S)>20)!$S($$GET^XPAR("SYS","XU VC CASE SENSITIVE"):S'?.ANP,1:S'?.UNP)!(S[";")!(S["^")!(S[":") Q "1^"_$$AVHLPTXT 104 I (S?8.20A)!(S?8.20N)!(S?8.20P)!(S?8.20AN)!(S?8.20AP)!(S?8.20NP) Q "2^VERIFY CODE must be a mix of alpha and numerics and punctuation." 105 I $D(^VA(200,DA,.1)),EC=$P(^(.1),U,2) Q "3^This code is the same as the current one." 106 I $D(^VA(200,DA,"VOLD",EC)) Q "4^This has been used previously as the VERIFY CODE." 107 I EC=$P(^VA(200,DA,0),U,3) Q "5^VERIFY CODE must be different than the ACCESS CODE." 108 I S[$P(NA,"^")!(S[$P(NA,"^",2)) Q "6^Name cannot be part of code." 109 Q 0 110 ; 111 VST(XUH,%) ; 112 W:$L(XUH)&% !,"OK, Verify code has been changed!" 113 N FDA,IEN,ERR S IEN=DA_"," 114 S:XUH="" XUH="@" ;11.2 get triggerd 115 S FDA(200,IEN,11)=XUH D FILE^DIE("","FDA","ERR") 116 I $D(ERR) D ^%ZTER 117 S:DA=DUZ DUZ("NEWCODE")=XUH Q 118 ; 119 DEL ; 120 X ^%ZOSF("EON") W $C(7) S DIR(0)="Y",DIR("A")="Sure you want to delete" D ^DIR I Y'=1 W:$X>55 !?9 W $C(7)," <Nothing Deleted>" 121 Q 122 ; 123 AAUTO ;Auto-get Access codes 124 N XUK,Y 125 X ^%ZOSF("EON") F XUK=1:1:3 D AGEN Q:(Y=1)!($D(DIRUT)) 126 Q 127 ; 128 AGEN ;Generate a ACCESS code 129 S XUU=$$AC^XUS4 S X=$$EN^XUSHSH(XUU),XUH=X I $D(^VA(200,"A",X))!$D(^VA(200,"AOLD",X)) G AGEN 130 D CLR W "The new ACCESS CODE is: ",XUU," This is ",XUK," of 3 tries." 131 D YN 132 Q 133 ; 134 AHELP S XUU=$$AC^XUS4 S X=$$EN^XUSHSH(XUU) I $D(^VA(200,"A",X))!$D(^VA(200,"AOLD",X)) G AHELP 135 W !,"Here is an example of an acceptable Access Code: ",XUU,! 136 Q 137 ; 138 VHELP S XUU=$$VC^XUS4 S X=$$EN^XUSHSH(XUU) I ($P($G(^VA(200,DA,0)),U,3)=X)!$D(^VA(200,DA,"VOLD",X)) G VHELP 139 W !,"Here is an example of an acceptable Verify Code: ",XUU,! 140 Q 141 ; 142 VAUTO ;Auto-get Access codes 143 N XUK 144 X ^%ZOSF("EON") F XUK=1:1:3 D VGEN Q:(Y=1)!($D(DIRUT)) 145 Q 146 ; 147 VGEN ;Generate a VERIFY code 148 S XUU=$$VC^XUS4 S X=$$EN^XUSHSH(XUU),XUH=X I ($P($G(^VA(200,DA,0)),U,3)=X)!$D(^VA(200,DA,"VOLD",X)) G VGEN 149 D CLR W "The new VERIFY CODE is: ",XUU," This is ",XUK," of 3 tries." 150 D YN 151 Q 152 YN ;Ask if want to keep 153 N DIR 154 S Y=1 Q:XUK=3 S DIR(0)="YA",DIR("A")=" Do you want to keep this one? ",DIR("B")="YES",DIR("?",1)="If you don't like this code, we can auto-generate another.",DIR("?")="Remember you only get 3 tries!" 155 D ^DIR Q:(Y=1)!$D(DIRUT) D CLR W:XUK=2 "O.K. You'll have to keep the next one!",! 156 Q 157 ; 158 OUT ; 159 K DUOUT S:$D(DIRUT) DUOUT=1 160 X ^%ZOSF("EON") W ! 161 K DIR,DIRUT,XUKO,XUAUTO,XUU,XUH,XUK,XUI S X="" 162 Q 163 ; 164 CHKCUR() ;Check user knows current code, Return 1 if OK to continue 165 Q:DA'=DUZ 1 ;Only ask user 166 Q:$P($G(^VA(200,DA,.1)),U,2)="" 1 ;Must have an old one 167 S XUK=0 D CLR 168 CHK1 W "Please enter your CURRENT verify code: " D GET Q:$D(DIRUT) 0 169 I $P(^VA(200,DA,.1),U,2)=$$EN^XUSHSH(X) Q 1 170 D CLR W "Sorry that is not correct!",! 171 S XUK=XUK+1 G:XUK<3 CHK1 172 Q 0 173 ; 174 BRCVC(XV1,XV2) ;Broker change VC, return 0 if good, '1^msg' if bad. 175 N XUU,XUH 176 Q:$G(DUZ)'>0 "1^Bad DUZ" S DA=DUZ,XUH=$$EN^XUSHSH(XV2) 177 I $P($G(^VA(200,DUZ,.1)),"^",2)'=$$EN^XUSHSH(XV1) Q "1^Sorry that isn't the correct current code" 178 S Y=$$VCHK(XV2,XUH) Q:Y Y 179 D VST(XUH,0),CALL^XUSERP(DA,2) 180 Q 0 181 ; 182 AVHLPTXT(%) ; 183 Q "Enter "_$S($G(%):"6-20",1:"8-20")_" characters mixed alphanumeric and punctuation (except '^', ';', ':')." 184 ; 185 ;Left over code, Don't think it is called anymore. 186 G XUS2^XUVERIFY ;All check or return user attributes moved to XUVERIFY 187 USER G USER^XUVERIFY 188 EDIT G EDIT^XUVERIFY -
WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSCLEAN.m
r613 r623 1 XUSCLEAN ;SF/STAFF - CLEANUP BEFORE EXIT ;10/26/06 08:12 2 ;;8.0;KERNEL;**13,59,165,353,434**;Jul 10, 1995;Build 6 3 H ;;Exit point for all R/S applications 4 LOCK ;Unlock any locks 5 S U="^" 6 ;Unwind Exit Actions 7 I $D(^XUTL("XQ",$J,"T")) S %XQEA=^("T") D 8 . F %XQEA1=%XQEA:-1:1 I $D(^XUTL("XQ",$J,%XQEA1)),$P(^(%XQEA1),U,16) S %XQEA2=+^(%XQEA1) I $D(^DIC(19,%XQEA2,15)),$L(^(15)) X ^(15) 9 K %XQEA,%XQEA1,%XQEA2 10 ;Jump if the home device was closed 11 G:$D(IO("C")) H2 12 ;Clear the screen 13 I $S($D(IOST)[0:1,IOST="":1,IOST["C-":1,1:0),'$D(XUERF) W !!!!!!!!!!!!!!!!!!!!!!! 14 I $D(XQNOLOG) W !!,"==> Sorry, all activity on this volume set is being halted! Try again later.",*7,*7,*7,!!!! 15 ;W !!,"Halting at " S X=$P($H,",",2),Y=$E(X#3600\60+100,2,3),X=X\3600,Z=0 S:X>11 Z=1 S:'X X=12 S:X>12 X=X-12 W X,":",Y," ",$S(Z:"pm",1:"am") 16 W !!,"Logged out at "_$$HTE^XLFDT($H,"1FMP") 17 D:$D(DUZ("NEWCODE")) NEWCODE 18 ;NON-R/S exit thru here also. 19 H2 ;No talking after this point 20 D C,XUTL 21 ;un-comment the following line if you want FM space recall cleared 22 ;after each session. 23 ;K ^DISV($G(DUZ,0)) 24 S:'($D(XQXFLG)#2) XQXFLG="" I $D(XQCH),XQCH="HALT" S $P(XQXFLG,U,3)="" 25 I ($D(XQNOHALT)#2)!($D(ZTQUEUED)#2)!($P(XQXFLG,U,3)="XUP") K XQNOHALT,XQXFLG Q ;Return to REST^XQ12, ^XUP or Taskman. 26 ;This was for modem hang up code. Obsolete now 27 I $D(^%ZIS("H"))#2 X ^("H") 28 ;Go to ZU to do final halt. 29 G HALT^ZU 30 ; 31 TOUCH ;SR. API to set the keepalive node, Only set once a day 32 Q:+$G(^XUTL("XQ",$J,"KEEPALIVE"))=+$H 33 S ^XUTL("XQ",$J,"KEEPALIVE")=$H 34 Q 35 ; 36 C ;Do device close execute, User exit. 37 N XUDEV 38 S XUDEV=$S($D(^XUTL("XQ",$J,"IOS")):^("IOS"),1:"") 39 D ^%ZISC,BYE 40 Q 41 ; 42 ;Called from Broker, VistaLink, R/S 43 BYE ;Set flags to show user has left. Called from anyplace the user exits 44 N DA,DIK,R0,% 45 I $G(^VA(200,+$G(DUZ),1.1)) S $P(^VA(200,DUZ,1.1),"^",3)=0 46 S DA=+$G(^XUTL("XQ",$J,0)) D LOUT(DA) 47 I $D(^XUSEC(0,DA,0)) D 48 . S R0=^XUSEC(0,DA,0) 49 . I $G(IO("IP"))]"",$P(R0,"^",13)]"" S %=$$CMD^XWBCAGNT(.R0,"XWB DELETE HANDLE",$P(R0,"^",13)) 50 K ^XUTL("XQ",$J) 51 Q 52 ; 53 LOUT(DA) ;Enter log-out time, in Sign-on log 54 N DIK 55 I $D(^XUSEC(0,DA,0)) D 56 . S R0=^(0),$P(^(0),"^",4)=$$NOW^XLFDT,DIK="^XUSEC(0,",DIK(1)="3" D EN1^DIK 57 Q 58 ; 59 XUTL ;Cleanup JOB temporary Globals 60 N XQN D CLEAN^DILF ;Cleanup FM too. 61 K ^XUTL($J),^UTILITY($J),^TMP($J) 62 S XQN=" " F S XQN=$O(^XUTL(XQN)) Q:XQN="" K:"^XQO^XGATR^XGKB^"'[XQN ^XUTL(XQN,$J) 63 S XQN=" " F S XQN=$O(^TMP(XQN)) Q:XQN="" K ^TMP(XQN,$J) 64 S XQN=" " F S XQN=$O(^UTILITY(XQN)) Q:XQN="" K:"^ROU^GLO^LRLTR"'[XQN ^UTILITY(XQN,$J) 65 K ^XUTL("ZISPARAM",$I) 66 Q 67 ; 68 NEWCODE ;Remind user they changed there VC. 69 W !!,*7,"But, as I recall...",!,"You've changed your VERIFY CODE during this session.",!,"Please remember it for next time." H 4 70 Q 71 ; 72 ;Entry point to clear symbol table 73 KILL ;SR. This is what was requested. 74 K %1,%2,%3 S %3=+$G(^XUTL("XQ",$J,"T")) 75 ;See if Menu stack has Variable to protect. 76 F %1=%3:-1:1 S %2=+$G(^XUTL("XQ",$J,%1)),%2=$G(^DIC(19,%2,"NOKILL")) I %2]"" N @%2 77 ;Fall into next part of kill. 78 KILL1 ;To clean up ALL but kernel variables. 79 I $$BROKER^XWBLIB S %2=$P($T(VARLST^XWBLIB),";;",2) I %2]"" N @%2 ;Protect Broker variables. 80 N XGWIN,XGDI,XGEVENT ;P434 remove KWAPI 81 N XQAEXIT,XQAUSER,XQX1,XQAKILL,XQAID 82 ;p434 add DILOCKTM, remove XRTL, %ZH0 83 K (DUZ,DTIME,DILOCKTM,DT,DISYS,IO,IOBS,IOF,IOM,ION,IOSL,IOST,IOT,IOS,IOXY,U,XQVOL,XQY,XQY0,XQDIC,XQPSM,XQPT,XQAUDIT,XQXFLG,ZTSTOP,ZTQUEUED,ZTREQ) 84 K IO("C"),IO("Q") 85 Q 86 ; 87 XMR ;Entry point from XUS to DO xmr and cleanup after. 88 N XQXFLG ;p434 89 D NEXT^XUS1 S XQXFLG="",XQXFLG("HALT")=1 G H2 1 XUSCLEAN ;SF/STAFF - CLEANUP BEFORE EXIT ;05/26/2005 14:28 2 ;;8.0;KERNEL;**13,59,165,353**;Jul 10, 1995;Build 1 3 H ;;Exit point for all R/S applications 4 LOCK ;Unlock any locks 5 S U="^" 6 ;Unwind Exit Actions 7 I $D(^XUTL("XQ",$J,"T")) S %XQEA=^("T") D 8 . F %XQEA1=%XQEA:-1:1 I $D(^XUTL("XQ",$J,%XQEA1)),$P(^(%XQEA1),U,16) S %XQEA2=+^(%XQEA1) I $D(^DIC(19,%XQEA2,15)),$L(^(15)) X ^(15) 9 K %XQEA,%XQEA1,%XQEA2 10 ;Jump if the home device was closed 11 G:$D(IO("C")) H2 12 ;Clear the screen 13 I $S($D(IOST)[0:1,IOST="":1,IOST["C-":1,1:0),'$D(XUERF) W !!!!!!!!!!!!!!!!!!!!!!! 14 I $D(XQNOLOG) W !!,"==> Sorry, all activity on this volume set is being halted! Try again later.",*7,*7,*7,!!!! 15 ;W !!,"Halting at " S X=$P($H,",",2),Y=$E(X#3600\60+100,2,3),X=X\3600,Z=0 S:X>11 Z=1 S:'X X=12 S:X>12 X=X-12 W X,":",Y," ",$S(Z:"pm",1:"am") 16 W !!,"Logged out at "_$$HTE^XLFDT($H,"1FMP") 17 D:$D(DUZ("NEWCODE")) NEWCODE 18 ;NON-R/S exit thru here also. 19 H2 ;No talking after this point 20 D C,XUTL 21 ;un-comment the following line if you want FM space recall cleared 22 ;after each session. 23 ;K ^DISV($G(DUZ,0)) 24 S:'($D(XQXFLG)#2) XQXFLG="" I $D(XQCH),XQCH="HALT" S $P(XQXFLG,U,3)="" 25 I ($D(XQNOHALT)#2)!($D(ZTQUEUED)#2)!($P(XQXFLG,U,3)="XUP") K XQNOHALT,XQXFLG Q ;Return to REST^XQ12, ^XUP or Taskman. 26 ;This was for modem hang up code. Obsolete now 27 I $D(^%ZIS("H"))#2 X ^("H") 28 ;Go to ZU to do final halt. 29 G HALT^ZU 30 ; 31 TOUCH ;SR. API to set the keepalive node, Only set once a day 32 Q:+$G(^XUTL("XQ",$J,"KEEPALIVE"))=+$H 33 S ^XUTL("XQ",$J,"KEEPALIVE")=$H 34 Q 35 ; 36 C ;Do device close execute, User exit. 37 N XUDEV 38 S XUDEV=$S($D(^XUTL("XQ",$J,"IOS")):^("IOS"),1:"") 39 D ^%ZISC,BYE 40 Q 41 ; 42 ;Called from Broker, VistaLink, R/S 43 BYE ;Set flags to show user has left. Called from anyplace the user exits 44 N DA,DIK,R0,% 45 I $G(^VA(200,+$G(DUZ),1.1)) S $P(^VA(200,DUZ,1.1),"^",3)=0 46 S DA=+$G(^XUTL("XQ",$J,0)) D LOUT(DA) 47 I $D(^XUSEC(0,DA,0)) D 48 . S R0=^XUSEC(0,DA,0) 49 . I $G(IO("IP"))]"",$P(R0,"^",13)]"" S %=$$CMD^XWBCAGNT(.R0,"XWB DELETE HANDLE",$P(R0,"^",13)) 50 K ^XUTL("XQ",$J) 51 Q 52 ; 53 LOUT(DA) ;Enter log-out time, in Sign-on log 54 N DIK 55 I $D(^XUSEC(0,DA,0)) D 56 . S R0=^(0),$P(^(0),"^",4)=$$NOW^XLFDT,DIK="^XUSEC(0,",DIK(1)="3" D EN1^DIK 57 Q 58 ; 59 XUTL ;Cleanup JOB temporary Globals 60 N XQN D CLEAN^DILF ;Cleanup FM too. 61 K ^XUTL($J),^UTILITY($J),^TMP($J) 62 S XQN=" " F S XQN=$O(^XUTL(XQN)) Q:XQN="" K:"^XQO^XGATR^XGKB^"'[XQN ^XUTL(XQN,$J) 63 S XQN=" " F S XQN=$O(^TMP(XQN)) Q:XQN="" K ^TMP(XQN,$J) 64 S XQN=" " F S XQN=$O(^UTILITY(XQN)) Q:XQN="" K:"^ROU^GLO^LRLTR"'[XQN ^UTILITY(XQN,$J) 65 K ^XUTL("ZISPARAM",$I) 66 Q 67 ; 68 NEWCODE ;Remind user they changed there VC. 69 W !!,*7,"But, as I recall...",!,"You've changed your VERIFY CODE during this session.",!,"Please remember it for next time." H 4 70 Q 71 ; 72 ;Entry point to clear symbol table 73 KILL ;SR. This is what was requested. 74 K %1,%2,%3 S %3=+$G(^XUTL("XQ",$J,"T")) 75 ;See if Menu stack has Variable to protect. 76 F %1=%3:-1:1 S %2=+$G(^XUTL("XQ",$J,%1)),%2=$G(^DIC(19,%2,"NOKILL")) I %2]"" N @%2 77 ;Fall into next part of kill. 78 KILL1 ;To clean up ALL but kernel variables. 79 I $$BROKER^XWBLIB S %2=$P($T(VARLST^XWBLIB),";;",2) I %2]"" N @%2 ;Protect Broker variables. 80 N KWAPI,XGWIN,XGDI,XGEVENT 81 N XQAEXIT,XQAUSER,XQX1,XQAKILL,XQAID 82 K (DUZ,DTIME,DT,DISYS,IO,IOBS,IOF,IOM,ION,IOSL,IOST,IOT,IOS,IOXY,U,XRTL,%ZH0,XQVOL,XQY,XQY0,XQDIC,XQPSM,XQPT,XQAUDIT,XQXFLG,ZTSTOP,ZTQUEUED,ZTREQ) 83 K IO("C"),IO("Q") 84 Q 85 ; 86 XMR ;Entry point from XUS to DO xmr and cleanup after. 87 D NEXT^XUS1 S XQXFLG="",XQXFLG("HALT")=1 G H2 -
WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSERBLK.m
r613 r623 1 XUSERBLK ;SF/RWF - Bulk user (new person) COMPUTER ACCESS ;02/26/2008 2 ;;8.0;KERNEL;**20,214,230,289,419,490**;Jul 10, 1995;Build 5 3 ; Per VHA Directive 2004-038, this routine should not be modified. 4 ; Option: XUSERBLK 5 ; This routine allows the Cloning of one person to a group of others. 6 A ; 7 I $G(DUZ)'>0 W !!,"You are not a known user and can't use this option." Q 8 N DIC,X,Y,XUTMP,DA,DIR,XUTERMDT,XUSER,XUY,%ZIS,XUIOP,XMQUIET 9 K ^TMP($J) 10 B1 W @IOF,!?26,"Batch Entry of New Persons" 11 W !?26,"--------------------------",!!,"Please select a person to copy from" 12 K DIC S DIC(0)="AEQZ",DIC("A")="Template PERSON: ",DIC="^VA(200," D ^DIC 13 Q:$D(DTOUT)!$D(DUOUT) 14 G B1:Y=-1 15 ; Show INFO to be copied" 16 S XUTMP=+Y,XUTMP(0)=$P(Y,U,2),DA=+Y D EN^DIQ 17 S DIR(0)="Y",DIR("A")="Is this the person whose data you want cloned" D ^DIR Q:$D(DIRUT) G B1:'Y 18 W !!,"You may enter a date, when the users that are being created/updated",!,"will no longer have access to the system." 19 S DIR(0)="DAO^DT::AEF" 20 S DIR("A")="Enter (optional) TERMINATION DATE: " 21 D ^DIR Q:$D(DTOUT)!$D(DUOUT) 22 S XUTERMDT=Y 23 K XUSER S XUSER=0 24 B2 ; 25 W !!,?26,"Batch Entry of New Persons",!,?26,"--------------------------",! 26 W !,"Clone of: ",XUTMP(0) I XUTERMDT W ?49,"TERMINATION DATE: ",$$FMTE^XLFDT(XUTERMDT) 27 ;; 28 B3 F S XUY=$$ADD^XUSERNEW Q:XUY<0 D ;Create new entry 29 . I '$P(XUY,U,3) D 30 . . S DIR(0)="Y",DIR("A")=$P(XUY,U,2)_" is an existing user. Do you want to include" D ^DIR I Y'=1 S XUY=-1 Q 31 . . S DIR(0)="Y",DIR("A")="Clear out KEYS, FILES, SECONDARY MENUS first" D ^DIR 32 . . S:Y=1 $P(XUY,U,4)=1 33 . . Q 34 . I XUY>0 D 35 . . S DIR(0)="Y",DIR("A")="Do You Want To Clone PERSON CLASS" D ^DIR 36 . . S:Y=1 $P(XUY,U,5)=1 37 . S:XUY>0 XUSER=XUSER+1,XUSER(XUSER)=XUY W !!,"Next!" 38 . Q 39 B4 ; 40 Q:XUSER'>0 41 I XUTERMDT D 42 . N XUZT 43 . S XUZT("ZTDTH")=XUTERMDT 44 . W !!,"Queueing automatic deactivation for ",$$FMTE^XLFDT(XUTERMDT) 45 . S X=$$NODEV^XUTMDEVQ("CHECK^XUSTERM1",,,.XUZT,1) 46 W !!,"Where do you want to print the COMPUTER ACCOUNT NOTIFICATION LETTERS?" 47 S XMQUIET=1 48 S %ZIS="NMQ" D ^%ZIS Q:POP ; "N" means don't open device 49 K XMQUIET 50 S XUIOP=ION_";"_IOST_";"_IOM_";"_IOSL 51 D HOME^%ZIS 52 ;I ION["P-MESSAGE-HFS" G START 53 I '$D(IO("Q")) G CLONE 54 START ; 55 N XUZT 56 S XUZT("ZTDTH")=$H 57 S X=$$NODEV^XUTMDEVQ("CLONE^XUSERBLK",,"XUIOP;XUTMP;XUTERMDT;XUSER;XUSER(",.XUZT,1) 58 Q 59 ;; 60 CLONE ;;Do work 61 N XUTEXT,XU1,%,DA,XUNEW,XUPURGE 62 S XUTEXT=$O(^DIC(9.2,"B",$$GET^XUPARAM("XUSER COMPUTER ACCOUNT","N"),0)) 63 F XU1=1:1:XUSER S %=XUSER(XU1),DA=+%,XUNEW=$P(%,U,3),XUPURGE=$P(%,U,4) D C2,UPDATE("ORD",DA) 64 K ^TMP($J) 65 Q 66 C2 ; 67 N XUU,XUU2,XFDA,XUH,XUH2,XIEN,XERR,Y,XMZ,XMM,XMDT 68 I '$D(ZTQUEUED) W !!?8,$S(XUNEW:"CREATING A NEW ACCOUNT FOR '"_$P(XUSER(XU1),U,2)_"'",1:"CONVERTING "_$P(XUSER(XU1),U,2)_"'S ACCOUNT OVER"),!!,"One moment please..." 69 D BLDFDA 70 I $P(^VA(200,DA,0),U,3)']"" S XUNEW=1 ;if no access code treat as new 71 I $P($G(^VA(200,DA,.1)),U,2)']"" S XUNEW=1 ;If no verify code treat as new 72 S (XUU,XUU2)="unchanged",$P(^VA(200,DA,0),U,11)=XUTERMDT 73 I XUNEW D ACODE S @XFDA@(200,DA_",",2)=XUH D VCODE S @XFDA@(200,DA_",",11)=XUH2 74 D UPDATE^DIE("",XFDA,XIEN,"XERR") K @XFDA 75 I XUNEW,XUTEXT>0 D LET(DA,XUTEXT) 76 I $D(^XMB(3.7,DA,0))[0 S Y=DA K XMZ D NEW^XM K XMDT,XMM,XMZ 77 Q 78 ; 79 BLDFDA ;Build the FDA 80 N X2,X3,X4,X5,X6,X7,XUNODE,XU 81 S XFDA="^TMP($J,""XFDA"")",XIEN="^TMP($J,""XIEN"")" K ^TMP($J) 82 ;Move piece on nodes from list, Build XU only once 83 F X2=1:1 S XUNODE=$P($T(DATA+X2),";;",2) Q:XUNODE="" D 84 . F X3=1:1 S X7=$P(XUNODE,U,X3) Q:X7="" S X4=$$GETDD(200,X7),X5=$P(X4,";"),X6=$P(X4,";",2) D 85 . . I '$D(XU(2,X5)) S XU(2,X5)=$G(^VA(200,XUTMP,X5)) 86 . . S:$P(XU(2,X5),U,X6)]"" @XFDA@(200,DA_",",X7)=$P(XU(2,X5),U,X6) 87 . . Q 88 . Q 89 D SUBFILE 90 Q 91 ; 92 GETDD(FI,FE) ;Return node;piece for a field 93 Q $P($G(^DD(FI,FE,0)),U,4) 94 ; 95 DATA ;;field# 96 ;;3^8^15^29^28 97 ;;200.04^200.05^200.06^200.09^200.1^201^ 98 ;;41^41.1^41.2 99 ;;101.01^101.02 100 ;;9.21^9.22 101 ;; 102 ; 103 ACODE ; 104 N Z 105 F Z=0:0 S XUU=$$AC^XUS4(),XUH=$$EN^XUSHSH(XUU) Q:'($D(^VA(200,"AOLD",XUH))!$D(^VA(200,"A",XUH))) 106 Q 107 ; 108 VCODE ; 109 S XUU2=$$VC^XUS4(),XUH2=$$EN^XUSHSH(XUU2) 110 Q 111 ; 112 SUBFILE ;Move subfiles: Subscript, Subfile#, DINUM, Fields 113 N XCNT S XCNT=0 114 KEY D MULTI(51,200.051,1,".01,3") 115 PATH ;D MULTI(19.8,".01") 116 FOF D MULTI("FOF",200.032,1,".01,1,2,3,4,5,6") 117 DIV D MULTI(2,200.02,1,".01") 118 SEC D MULTI(203,200.03,0,".01,2") 119 TAB D MULTI("ORD",200.010113,0,".01,.02,.03") 120 PSCLSS I $P($G(XUSER(XU1)),U,5)=1 D PRSNCL(DA) 121 Q 122 ; 123 MULTI(XSS,XSF,XDN,XDD) ;Build new data 124 I XUPURGE D CLEAR(DA,XSS) 125 Q:'$D(^VA(200,XUTMP,XSS,0)) 126 ;S X=^(0),Y=$S($D(^VA(200,DA,X2,0)):^(0),1:"") 127 F X1=0:0 S X1=$O(^VA(200,XUTMP,XSS,X1)) Q:X1'>0 S X=^(X1,0) D 128 . F X2=1:1 S X3=$P(XDD,",",X2) Q:X3="" D 129 . . I X3'=.01 S @XFDA@(XSF,"?+"_XCNT_","_DA_",",X3)=$$VAL(X,X3,XSF) Q 130 . . S XCNT=XCNT+1,@XFDA@(XSF,"?+"_XCNT_","_DA_",",.01)=$P(X,U,1) 131 . . S:XDN @XIEN@(XCNT)=X1 132 . . Q 133 . Q 134 Q 135 ; 136 VAL(V,FE,FI) ;Get value 137 N % S %=$$GETDD(FI,FE),%=$P(%,";",2) Q $P(V,"^",%) 138 ; 139 LET(DA,XUTEXT) ;Write access letter 140 N DIWF,FR,TO,BY,IOP 141 S DIWF="^DIC(9.2,"_XUTEXT_",1,",DIWF(1)=200,FR=DA,TO=DA,BY="NUMBER",IOP=XUIOP D EN2^DIWF 142 Q 143 ; 144 CLEAR(X4,X2) ;Clear subfile first, IEN, Subscript 145 Q:$D(^VA(200,X4,X2,0))[0 N C,XUFN,XDEL,XMSG 146 S C=",",XDEL=$NA(^TMP($J,"XUBLK2")),XUFN=+$P(^VA(200,X4,X2,0),"^",2) 147 F X1=0:0 S X1=$O(^VA(200,X4,X2,X1)) Q:X1'>0 D 148 . I X2=51 S %=$$DEL^XQKEY(X4,X1) Q ;Special case for KEYS 149 . S @XDEL@(XUFN,X1_C_X4_C,.01)="@" 150 . Q 151 I $D(@XDEL)>1 D FILE^DIE("",XDEL,"XMSG") ;I $D(XMSG) ZW XMSG 152 Q 153 ; 154 UPDATE(XX,USRIEN) ;Update effective date 155 N PC,PC1 156 S PC=$O(^VA(200,USRIEN,XX,"A"),-1) Q:PC'>0 157 S PC=0 F S PC=$O(^VA(200,USRIEN,XX,PC)) Q:PC'>0 D 158 .S PC1=$P($G(^VA(200,USRIEN,XX,PC,0)),"^",3) 159 .I (PC1="")!(PC1'<DT) D DOPD 160 Q 161 ; 162 DOPD ; 163 L +^VA(200,DA,XX,PC,0):20 I '$T D Q 164 .W !,"===> The user is locked. Please try this option again." 165 S $P(^VA(200,USRIEN,XX,PC,0),"^",2)=DT 166 L -^VA(200,USRIEN,XX,PC,0) 167 Q 168 ; 169 PRSNCL(USERIEN) ; 170 N XUDATA,XUPSC,XUEFDA,XUEXDA,ZZ 171 S XUDATA=$O(^VA(200,XUTMP,"USC1","A"),-1) Q:XUDATA'>0 172 S XUDATA=$G(^VA(200,XUTMP,"USC1",XUDATA,0)) Q:XUDATA="" 173 S XUPSC=$P(XUDATA,"^") 174 S XUEFDA=$P(XUDATA,"^",2) I XUEFDA'>DT S XUEFDA=DT 175 S XUEXDA=$P(XUDATA,"^",3) 176 I XUEXDA<DT,XUEXDA'="" Q 177 N XULAST,XULDATA 178 S XULAST=$O(^VA(200,USERIEN,"USC1","A"),-1) 179 S ZZ(1,200.05,"+2,"_USERIEN_",",.01)=XUPSC 180 S ZZ(1,200.05,"+2,"_USERIEN_",",2)=XUEFDA 181 S ZZ(1,200.05,"+2,"_USERIEN_",",3)=XUEXDA 182 D UPDATE^DIE("","ZZ(1)") 183 Q:XULAST'>0 184 S XULDATA=$G(^VA(200,USERIEN,"USC1",XULAST,0)) 185 S XULDATA=$P(XULDATA,"^",3) 186 Q:XULDATA'>DT 187 S $P(^VA(200,USERIEN,"USC1",XULAST,0),"^",3)=DT 188 Q 1 XUSERBLK ;SF/RWF - Bulk user (new person) COMPUTER ACCESS ; 5/23/2006 2 ;;8.0;KERNEL;**20,214,230,289,419**;Jul 10, 1995;Build 5 3 ; This routine allows the Cloning of one person to a group of others. 4 A ; 5 I $G(DUZ)'>0 W !!,"You are not a known user and can't use this option." Q 6 N DIC,DIR,%,L,XUIOP,XUNODE,XU1,X1,X2,X3,X4,X5,X6,XUTEXT,XUNEW,XUSER,XUTMP,XUTERMDT,XUH,XUU,XUU2,M,P,XU 7 K ^TMP($J) 8 B1 W @IOF,!?26,"Batch Entry of New Persons" 9 W !?26,"--------------------------",!!,"Please select a person to copy from" 10 K DIC S DIC(0)="AEQZ",DIC("A")="Template PERSON: ",DIC="^VA(200," D ^DIC 11 G QUIT:$D(DTOUT)!$D(DUOUT),B1:Y=-1 12 ; Show INFO to be copied" 13 S XUTMP=+Y,XUTMP(0)=$P(Y,U,2),DA=+Y D EN^DIQ 14 S DIR(0)="Y",DIR("A")="Is this the person data you want cloned" D ^DIR G B1:'Y 15 W !,"You may enter a date, when the users that are being created/updated",!,"will no longer have access to the system." 16 S XUTERMDT="",%DT="AEF",%DT(0)=DT,%DT("A")="Enter (optional) TERMINATION DATE: " D ^%DT S:Y>0 XUTERMDT=Y 17 K XUSER S XUSER=0 18 B2 ; 19 W !!,?26,"Batch Entry of New Persons",!,?26,"--------------------------",! 20 W !,"Clone of: ",XUTMP(0) I XUTERMDT W ?50,"TERMINATION DATE: ",$$FMTE^XLFDT(XUTERMDT) 21 ;; 22 B3 F S XUY=$$ADD^XUSERNEW Q:XUY<0 D ;Create new entry 23 . I '$P(XUY,U,3) D 24 . . S DIR(0)="Y",DIR("A")=$P(XUY,U,2)_" is an existing user. Do you want to include" D ^DIR I Y'=1 S XUY=-1 Q 25 . . S DIR(0)="Y",DIR("A")="Clear out KEYS, FILES, SECONDARY MENUS first" D ^DIR 26 . . S:Y=1 $P(XUY,U,4)=1 27 . . Q 28 . I XUY>0 D 29 . . S DIR(0)="Y",DIR("A")="Do You Want To Clone PERSON CLASS" D ^DIR 30 . . S:Y=1 $P(XUY,U,5)=1 31 . S:XUY>0 XUSER=XUSER+1,XUSER(XUSER)=XUY W !,"Next!",! 32 . Q 33 B4 ; 34 G:XUSER'>0 QUIT 35 I XUTERMDT>0 S ZTRTN="CHECK^XUSTERM1",ZTIO="",ZTDTH=XUTERMDT D ^%ZTLOAD W !,"Automatic deactivation has been queued for this date.",! 36 W !!,"Where do you want to print the COMPUTER ACCOUNT NOTIFICATION LETTERS" 37 S %ZIS="MQ" D ^%ZIS G QUIT:POP 38 I ION["P-MESSAGE-HFS" G START 39 I '$D(IO("Q")) G CLONE 40 START ; 41 S ZTRTN="CLONE^XUSERBLK" F I="XUTMP","XUTERMDT","XUSER","XUSER(" S ZTSAVE(I)="" 42 K IO("Q") D ^%ZTLOAD 43 ;; 44 QUIT ; 45 K DIC,DIR,%,L,XUIOP,XUNODE,XU1,X1,X2,X3,X4,X5,X6,XUTEXT,XUNEW,XUSER,XUTMP,XUTERMDT,XUH,XUU,XUU2,M,P,XU 46 K ^TMP($J) 47 Q 48 ;; 49 CLONE ;;Do work 50 S XUTEXT=$O(^DIC(9.2,"B",$$GET^XUPARAM("XUSER COMPUTER ACCOUNT","N"),0)),XUIOP=ION_";"_IOST_";"_IOM_";"_IOSL 51 F XU1=1:1:XUSER S %=XUSER(XU1),DA=+%,XUNEW=$P(%,U,3),XUPURGE=$P(%,U,4) D C2,UPDATE("ORD",DA) 52 G QUIT 53 ; 54 C2 ; 55 N XUH,XUH2,XUU,XUU2 56 I '$D(ZTQUEUED) W !!?8,$S(XUNEW:"CREATING A NEW ACCOUNT FOR '"_$P(XUSER(XU1),U,2)_"'",1:"CONVERTING "_$P(XUSER(XU1),U,2)_"'S ACCOUNT OVER"),!!,"One moment please..." 57 D BLDFDA 58 I $P(^VA(200,DA,0),U,3)']"" S XUNEW=1 ;if no access code treat as new 59 I $P($G(^VA(200,DA,.1)),U,2)']"" S XUNEW=1 ;If no verify code treat as new 60 S (XUU,XUU2)="unchanged",$P(^VA(200,DA,0),U,11)=XUTERMDT 61 I XUNEW D ACODE S @XFDA@(200,DA_",",2)=XUH D VCODE S @XFDA@(200,DA_",",11)=XUH2 62 D UPDATE^DIE("",XFDA,XIEN,"XERR") K @XFDA 63 I XUNEW,XUTEXT>0 D LET(DA,XUTEXT) 64 I $D(^XMB(3.7,DA,0))[0 S Y=DA K XMZ D NEW^XM K XMDT,XMM,XMZ 65 Q 66 ; 67 BLDFDA ;Build the FDA 68 S XFDA="^TMP($J,""XFDA"")",XIEN="^TMP($J,""XIEN"")" K ^TMP($J) 69 ;Move piece on nodes from list, Build XU only once 70 F X2=1:1 S XUNODE=$P($T(DATA+X2),";;",2) Q:XUNODE="" D 71 . F X3=1:1 S X7=$P(XUNODE,U,X3) Q:X7="" S X4=$$GETDD(200,X7),X5=$P(X4,";"),X6=$P(X4,";",2) D 72 . . I '$D(XU(2,X5)) S XU(2,X5)=$G(^VA(200,XUTMP,X5)) 73 . . S:$P(XU(2,X5),U,X6)]"" @XFDA@(200,DA_",",X7)=$P(XU(2,X5),U,X6) 74 . . Q 75 . Q 76 D SUBFILE 77 Q 78 ; 79 GETDD(FI,FE) ;Return node;piece for a field 80 Q $P($G(^DD(FI,FE,0)),U,4) 81 ; 82 DATA ;;field# 83 ;;3^8^15^29^28 84 ;;200.04^200.05^200.06^200.09^200.1^201^ 85 ;;41^41.1^41.2 86 ;;101.01^101.02 87 ;;9.21^9.22 88 ;; 89 ; 90 ACODE ; 91 F Z=0:0 S XUU=$$AC^XUS4(),XUH=$$EN^XUSHSH(XUU) Q:'($D(^VA(200,"AOLD",XUH))!$D(^VA(200,"A",XUH))) 92 Q 93 ; 94 VCODE ; 95 S XUU2=$$VC^XUS4(),XUH2=$$EN^XUSHSH(XUU2) 96 Q 97 ; 98 SUBFILE ;Move subfiles: Subscript, Subfile#, DINUM, Fields 99 N XCNT S XCNT=0 100 KEY D MULTI(51,200.051,1,".01,3") 101 PATH ;D MULTI(19.8,".01") 102 FOF D MULTI("FOF",200.032,1,".01,1,2,3,4,5,6") 103 DIV D MULTI(2,200.02,1,".01") 104 SEC D MULTI(203,200.03,0,".01,2") 105 TAB D MULTI("ORD",200.010113,0,".01,.02,.03") 106 PSCLSS I $P($G(XUSER(XU1)),U,5)=1 D PRSNCL(DA) 107 Q 108 ; 109 MULTI(XSS,XSF,XDN,XDD) ;Build new data 110 I XUPURGE D CLEAR(DA,XSS) 111 Q:'$D(^VA(200,XUTMP,XSS,0)) 112 ;S X=^(0),Y=$S($D(^VA(200,DA,X2,0)):^(0),1:"") 113 F X1=0:0 S X1=$O(^VA(200,XUTMP,XSS,X1)) Q:X1'>0 S X=^(X1,0) D 114 . F X2=1:1 S X3=$P(XDD,",",X2) Q:X3="" D 115 . . I X3'=.01 S @XFDA@(XSF,"?+"_XCNT_","_DA_",",X3)=$$VAL(X,X3,XSF) Q 116 . . S XCNT=XCNT+1,@XFDA@(XSF,"?+"_XCNT_","_DA_",",.01)=$P(X,U,1) 117 . . S:XDN @XIEN@(XCNT)=X1 118 . . Q 119 . Q 120 Q 121 ; 122 VAL(V,FE,FI) ;Get value 123 N % S %=$$GETDD(FI,FE),%=$P(%,";",2) Q $P(V,"^",%) 124 ; 125 LET(DA,XUTEXT) ;Write access letter 126 N DIWF,FR,TO,BY 127 S DIWF="^DIC(9.2,"_XUTEXT_",1,",DIWF(1)=200,FR=DA,TO=DA,BY="NUMBER",IOP=XUIOP D EN2^DIWF 128 Q 129 ; 130 CLEAR(X4,X2) ;Clear subfile first, IEN, Subscript 131 Q:$D(^VA(200,X4,X2,0))[0 N C,XUFN,XDEL,XMSG 132 S C=",",XDEL=$NA(^TMP($J,"XUBLK2")),XUFN=+$P(^VA(200,X4,X2,0),"^",2) 133 F X1=0:0 S X1=$O(^VA(200,X4,X2,X1)) Q:X1'>0 D 134 . I X2=51 S %=$$DEL^XQKEY(X4,X1) Q ;Special case for KEYS 135 . S @XDEL@(XUFN,X1_C_X4_C,.01)="@" 136 . Q 137 I $D(@XDEL)>1 D FILE^DIE("",XDEL,"XMSG") ;I $D(XMSG) ZW XMSG 138 Q 139 ; 140 UPDATE(XX,USRIEN) ;Update effective date 141 N PC,PC1 142 S PC=$O(^VA(200,USRIEN,XX,"A"),-1) Q:PC'>0 143 S PC=0 F S PC=$O(^VA(200,USRIEN,XX,PC)) Q:PC'>0 D 144 .S PC1=$P($G(^VA(200,USRIEN,XX,PC,0)),"^",3) 145 .I (PC1="")!(PC1'<DT) D DOPD 146 Q 147 ; 148 DOPD ; 149 L +^VA(200,DA,XX,PC,0):20 I '$T D Q 150 .W !,"===> The user is locked. Please try this option again." 151 S $P(^VA(200,USRIEN,XX,PC,0),"^",2)=DT 152 L -^VA(200,USRIEN,XX,PC,0) 153 Q 154 ; 155 PRSNCL(USERIEN) ; 156 N XUDATA,XUPSC,XUEFDA,XUEXDA,ZZ 157 S XUDATA=$O(^VA(200,XUTMP,"USC1","A"),-1) Q:XUDATA'>0 158 S XUDATA=$G(^VA(200,XUTMP,"USC1",XUDATA,0)) Q:XUDATA="" 159 S XUPSC=$P(XUDATA,"^") 160 S XUEFDA=$P(XUDATA,"^",2) I XUEFDA'>DT S XUEFDA=DT 161 S XUEXDA=$P(XUDATA,"^",3) 162 I XUEXDA<DT,XUEXDA'="" Q 163 N XULAST,XULDATA 164 S XULAST=$O(^VA(200,USERIEN,"USC1","A"),-1) 165 S ZZ(1,200.05,"+2,"_USERIEN_",",.01)=XUPSC 166 S ZZ(1,200.05,"+2,"_USERIEN_",",2)=XUEFDA 167 S ZZ(1,200.05,"+2,"_USERIEN_",",3)=XUEXDA 168 D UPDATE^DIE("","ZZ(1)") 169 Q:XULAST'>0 170 S XULDATA=$G(^VA(200,USERIEN,"USC1",XULAST,0)) 171 S XULDATA=$P(XULDATA,"^",3) 172 Q:XULDATA'>DT 173 S $P(^VA(200,USERIEN,"USC1",XULAST,0),"^",3)=DT 174 Q -
WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSERNEW.m
r613 r623 1 XUSERNEW ;SF/RWF - ADD NEW USER ;5/13/08 17:19 2 ;;8.0;KERNEL;**16,49,134,208,157,313,351,419,467,480**;Jul 10, 1995;Build 38 3 ;;Per VHA Directive 2004-038, this routine should not be modified 4 ;In the call to NEW^XM for new users the variable XMZ must be undef. 5 ;on a reactivation XMZ should be set to the current max message number. 6 EN ;Add 7 N Y,XUN,DR,DIE,DA,DTOUT,DIWF,XMDT,XMM,XMZ 8 S Y=$$ADD("","",1) G EXIT:Y'>0,RE:$P(Y,U,3)'=1 9 S XUN=+Y ;XU USER ADD called in $$ADD 10 S DR="["_$$GET^XUPARAM("XUNEW USER","N")_"]" 11 S DIE=200,DA=XUN D XUDIE^XUS5 G:$D(DTOUT) EXIT 12 I $$GET1^DIQ(200,XUN_",",11,"I")="" W !,"Without a VERIFY code the user will not be able to sign-on!",$C(7),! 13 S Y=XUN K XMZ D NEW^XM K XMDT,XMM,XMZ 14 ;ACCESS LETTER, Also see XUSERBLK 15 W ! D LETTER(XUN,1) 16 K DIR,DIWF,XUTEXT 17 ; 18 ;Fall in from above, called from REACT 19 KEYS N DIR,XQHOLD,XQKEY,XQDA,XQAL,XQ6,XQFL 20 S DIR(0)="Y",DIR("B")="NO",DIR("A")="Do you wish to allocate security keys" D ^DIR G:$D(DIRUT) EXIT 21 I Y=1 S XQHOLD(XUN)="",XQKEY(0)=0,XQDA=0,XQAL=1,XQ6="",XQFL="" D KEY^XQ6 22 ; 23 ;Check on adding this user to user groups 24 I $P(^VA(200,XUN,0),U,3)'="" D ;Must have access code & mailbox 25 .N DIR,Y 26 .S DIR(0)="Y",DIR("B")="NO",DIR("A")="Do you wish to add this user to mail groups" D ^DIR Q:$D(DIRUT) 27 .I Y=1 D ENLOCAL1^XMVGRP(XUN) 28 .K XMDUN,XMDUZ,XMV 29 .Q 30 ; 31 EXIT K D0,DA,DDER,DDSFILE,DIE,DIC,DIR,DI,DICR,DIG,DIH,DISYS,DIU,DIV,DIWT,DLAYGO,DR,DQ,K,I,X,X1,XQHOLD,XQKEY,XUN,XUSOLD,XMB,XMZ,Y,Z,XQ6,XQFL,DTOUT 32 Q 33 ; 34 RE ;Jump from new user to reactivate 35 S XUN=+Y,DIR("A")="This isn't a new user, Want to reactivate?",DIR(0)="Y",DIR("B")="NO" 36 D ^DIR 37 G EXIT:$D(DIRUT)!(Y'=1),RE2 38 ;Reactivate a user 39 REACT ;SEA/WDE-REACTIVATE A USER 40 N XUN,XUSOLD,DIE,DIC,DA,DR,FDA 41 S XUN=+$$LOOKUP^XUSER G EXIT:XUN<0 42 RE2 S XUSOLD=^VA(200,XUN,0) 43 S FDA(200,XUN_",",9.2)="@" ;Clear the Termination date 44 D UPDATE^DIE("E","FDA") 45 ;Show the screanman form 46 S DIE=200,DR="["_$$GET^XUPARAM("XUREACT USER","N")_"]",DA=XUN 47 D XUDIE^XUS5 G:$D(DTOUT) EXIT 48 I $P(^VA(200,XUN,0),U,3)="" W !!,"No ACCESS CODE has been entered.",$C(7),! 49 I $P(^VA(200,XUN,0),U,11)>0,$P(^(0),U,11)'>DT W !!,"User is still TERMINATED.",$C(7),! 50 I $$GET1^DIQ(200,XUN_",",11,"I")="" W !,"Without a VERIFY code the user will not be able to sign-on!",$C(7),! 51 N DIR 52 S DIR(0)="Y",DIR("A")="Deny access to old mail messages",DIR("B")="NO",DIR("?")="Enter a 'YES' to restrict access to old mail messages." 53 D ^DIR G:$D(DIRUT) EXIT 54 K XMZ S:Y=1 XMZ=+$P(^XMB(3.9,0),"^",3) S Y=XUN D NEW^XM K XMDT,XMM,XMZ 55 D REACT^XQ84(XUN) ;See if this user's menu trees need to be rebuilt 56 G KEYS 57 Q 58 ; 59 ADD(NP1,KEYS,NONC) ;Common point to do DIC call for adding a new person. 60 ;NP1 will be added to the default or what comes from the NPI field or the KSP. 61 ;KEYS is a list of Keys to give the new person 62 N DA,DR,DLAYGO,XUITNAME,XUS1,XUS2,DIC,DIE,DIK,NP2,Y 63 I $G(^XTV(8989.3,1,"NPI"))]"" X ^("NPI") S NP2=DR 64 S:'$D(NP2) NP2="1;"_$S($D(^XUSEC("XUSPF200",DUZ)):9,1:"9R~")_";4;41.99" 65 ;";41.99" is for adding National Provider Identifier 66 S DIC="^VA(200,",DIC(0)="AELMQ",DLAYGO=200,DIC("A")="Enter NEW PERSON's name (Family,Given Middle Suffix): ",DIC("DR")="",XUITNAME=1 67 D ^DIC S XUS1=Y G AX:(Y'>0)!($P(Y,U,3)'>0) 68 S DA=+$G(^VA(200,+XUS1,3.1)) I DA,'$G(NONC) D 69 . W !,"Name components." 70 . S DIE="^VA(20,",DR="1;2;3;5" 71 . L +^VA(20,DA,0):60 D ^DIE L -^VA(20,DA,0) 72 . I $D(Y)!$D(DTOUT) S DA=+XUS1,XUS1=-1 73 . E S $P(XUS1,U,2)=$P(^VA(200,+XUS1,0),U) 74 D:XUS1>0 75 . W !,"Now for the Identifiers." 76 . S DA=+XUS1,DIE="^VA(200,",DR=NP2_$S($D(NP1):";"_NP1,1:""),DIE("NO^")="OUTOK" 77 . L +^VA(200,DA,0):60 D ^DIE L -^VA(200,DA,0) 78 . S:$D(Y)!$D(DTOUT) XUS1=-1 79 I XUS1<0 D S XUS1=-1 80 . W !?5,"<'",$P(^VA(200,DA,0),U),"' DELETED>" 81 . S DIK="^VA(200," D ^DIK 82 . Q:$P($G(^DIC(3,0)),U)'="USER"!'$D(^DD(3,0)) 83 . S DIK="^DIC(3,",XUS1=$P($G(^DIC(3,DA,0)),U,16) D ^DIK 84 . Q:'XUS1!($P($G(^DIC(16,0)),U)'="PERSON")!'$D(^DD(16,0)) 85 . S DIK="^DIC(16,",DA=XUS1 D ^DIK 86 N XUSNPI S XUSNPI=$P($G(^VA(200,DA,"NPI")),"^") 87 I XUS1>0,+XUSNPI>0 D 88 . S XUSNPI=$$ADDNPI^XUSNPI("Individual_ID",DA,XUSNPI,$$NOW^XLFDT(),1) ;add NPI to multiple 89 . ; Initialize field 41.97 to 1 (YES) 90 . Q:+XUSNPI'>0 91 . N DIE,DR,DA S DIE="^VA(200,",DA=+XUS1,DR="41.97////1" D ^DIE 92 . Q 93 I XUS1>0,$D(KEYS) F XUS2=1:1 S Y=$P(KEYS,",",XUS2) Q:'$L(Y) D 94 . S %=$$ADD^XQKEY(XUS1,Y) I '% W !,"Key '",Y,"' not allocated" 95 I XUS1>0 D CALL^XUSERP(+XUS1,1) ;XQOR add 96 AX Q XUS1 97 ; 98 REPRINT ;Reprint letter 99 S DA=+$$LOOKUP^XUSER G EXIT:DA'>0 100 D LETTER(DA) 101 G EXIT 102 ; 103 LETTER(XUN,ASK) ;Print access letter 104 Q:'$G(XUN) 105 N DIWF,FR,TO,BY,DIR,XUTEXT 106 S XUTEXT=$$GET^XUPARAM("XUSER COMPUTER ACCOUNT","N"),XUTEXT=$O(^DIC(9.2,"B",XUTEXT,0)) 107 S DIR(0)="Y",DIR("A")="Print User Account Access Letter" 108 I XUTEXT>0 S Y=1 D:$G(ASK) ^DIR I Y=1 D 109 . S (XUU,XUU2)="________",DIWF="^DIC(9.2,XUTEXT,1,",DIWF(1)=200,FR=XUN,TO=XUN,BY="NUMBER" D EN2^DIWF 110 . Q 111 Q 1 XUSERNEW ;SF/RWF - ADD NEW USER ;6/27/07 2 ;;8.0;KERNEL;**16,49,134,208,157,313,351,419,467**;Jul 10, 1995;Build 12 3 ;In the call to NEW^XM for new users the variable XMZ must be undef. 4 ;on a reactivation XMZ should be set to the current max message number. 5 EN ;Add 6 N Y,XUN,DR,DIE,DA,DTOUT,DIWF,XMDT,XMM,XMZ 7 S Y=$$ADD("","",1) G EXIT:Y'>0,RE:$P(Y,U,3)'=1 8 S XUN=+Y ;XU USER ADD called in $$ADD 9 S DR="["_$$GET^XUPARAM("XUNEW USER","N")_"]" 10 S DIE=200,DA=XUN D XUDIE^XUS5 G:$D(DTOUT) EXIT 11 I $$GET1^DIQ(200,XUN_",",11,"I")="" W !,"Without a VERIFY code the user will not be able to sign-on!",$C(7),! 12 S Y=XUN K XMZ D NEW^XM K XMDT,XMM,XMZ 13 ;ACCESS LETTER, Also see XUSERBLK 14 W ! D LETTER(XUN,1) 15 K DIR,DIWF,XUTEXT 16 ; 17 ;Fall in from above, called from REACT 18 KEYS N DIR,XQHOLD,XQKEY,XQDA,XQAL,XQ6,XQFL 19 S DIR(0)="Y",DIR("B")="NO",DIR("A")="Do you wish to allocate security keys" D ^DIR G:$D(DIRUT) EXIT 20 I Y=1 S XQHOLD(XUN)="",XQKEY(0)=0,XQDA=0,XQAL=1,XQ6="",XQFL="" D KEY^XQ6 21 ; 22 ;Check on adding this user to user groups 23 I $P(^VA(200,XUN,0),U,3)'="" D ;Must have access code & mailbox 24 .N DIR,Y 25 .S DIR(0)="Y",DIR("B")="NO",DIR("A")="Do you wish to add this user to mail groups" D ^DIR Q:$D(DIRUT) 26 .I Y=1 D ENLOCAL1^XMVGRP(XUN) 27 .K XMDUN,XMDUZ,XMV 28 .Q 29 ; 30 EXIT K D0,DA,DDER,DDSFILE,DIE,DIC,DIR,DI,DICR,DIG,DIH,DISYS,DIU,DIV,DIWT,DLAYGO,DR,DQ,K,I,X,X1,XQHOLD,XQKEY,XUN,XUSOLD,XMB,XMZ,Y,Z,XQ6,XQFL,DTOUT 31 Q 32 ; 33 RE ;Jump from new user to reactivate 34 S XUN=+Y,DIR("A")="This isn't a new user, Want to reactivate?",DIR(0)="Y",DIR("B")="NO" 35 D ^DIR 36 G EXIT:$D(DIRUT)!(Y'=1),RE2 37 ;Reactivate a user 38 REACT ;SEA/WDE-REACTIVATE A USER 39 N XUN,XUSOLD,DIE,DIC,DA,DR,FDA 40 S XUN=+$$LOOKUP^XUSER G EXIT:XUN<0 41 RE2 S XUSOLD=^VA(200,XUN,0) 42 S FDA(200,XUN_",",9.2)="@" ;Clear the Termination date 43 D UPDATE^DIE("E","FDA") 44 ;Show the screanman form 45 S DIE=200,DR="["_$$GET^XUPARAM("XUREACT USER","N")_"]",DA=XUN 46 D XUDIE^XUS5 G:$D(DTOUT) EXIT 47 I $P(^VA(200,XUN,0),U,3)="" W !!,"No ACCESS CODE has been entered.",$C(7),! 48 I $P(^VA(200,XUN,0),U,11)>0,$P(^(0),U,11)'>DT W !!,"User is still TERMINATED.",$C(7),! 49 I $$GET1^DIQ(200,XUN_",",11,"I")="" W !,"Without a VERIFY code the user will not be able to sign-on!",$C(7),! 50 N DIR 51 S DIR(0)="Y",DIR("A")="Deny access to old mail messages",DIR("B")="NO",DIR("?")="Enter a 'YES' to restrict access to old mail messages." 52 D ^DIR G:$D(DIRUT) EXIT 53 K XMZ S:Y=1 XMZ=+$P(^XMB(3.9,0),"^",3) S Y=XUN D NEW^XM K XMDT,XMM,XMZ 54 D REACT^XQ84(XUN) ;See if this user's menu trees need to be rebuilt 55 G KEYS 56 Q 57 ; 58 ADD(NP1,KEYS,NONC) ;Common point to do DIC call for adding a new person. 59 ;NP1 will be added to the default or what comes from the NPI field of the KSP. 60 ;KEYS is a list of Keys to give the new person 61 N DA,DR,DLAYGO,XUITNAME,XUS1,XUS2,DIC,DIE,DIK,NP2,Y 62 I $G(^XTV(8989.3,1,"NPI"))]"" X ^("NPI") S NP2=DR 63 S:'$D(NP2) NP2="1;"_$S($D(^XUSEC("XUSPF200",DUZ)):9,1:"9R~")_";4;41.99" 64 ;";41.99" is for adding National Provider Identifier 65 S DIC="^VA(200,",DIC(0)="AELMQ",DLAYGO=200,DIC("A")="Enter NEW PERSON's name (Family,Given Middle Suffix): ",DIC("DR")="",XUITNAME=1 66 D ^DIC S XUS1=Y G AX:(Y'>0)!($P(Y,U,3)'>0) 67 S DA=+$G(^VA(200,+XUS1,3.1)) I DA,'$G(NONC) D 68 . W !,"Name components." 69 . S DIE="^VA(20,",DR="1;2;3;5" 70 . L +^VA(20,DA,0):60 D ^DIE L -^VA(20,DA,0) 71 . I $D(Y)!$D(DTOUT) S DA=+XUS1,XUS1=-1 72 . E S $P(XUS1,U,2)=$P(^VA(200,+XUS1,0),U) 73 D:XUS1>0 74 . W !,"Now for the Identifiers." 75 . S DA=+XUS1,DIE="^VA(200,",DR=NP2_$S($D(NP1):";"_NP1,1:""),DIE("NO^")="OUTOK" 76 . L +^VA(200,DA,0):60 D ^DIE L -^VA(200,DA,0) 77 . S:$D(Y)!$D(DTOUT) XUS1=-1 78 I XUS1<0 D S XUS1=-1 79 . W !?5,"<'",$P(^VA(200,DA,0),U),"' DELETED>" 80 . S DIK="^VA(200," D ^DIK 81 . Q:$P($G(^DIC(3,0)),U)'="USER"!'$D(^DD(3,0)) 82 . S DIK="^DIC(3,",XUS1=$P($G(^DIC(3,DA,0)),U,16) D ^DIK 83 . Q:'XUS1!($P($G(^DIC(16,0)),U)'="PERSON")!'$D(^DD(16,0)) 84 . S DIK="^DIC(16,",DA=XUS1 D ^DIK 85 N XUSNPI S XUSNPI=$P($G(^VA(200,DA,"NPI")),"^") 86 I XUS1>0,+XUSNPI>0 S XUSNPI=$$ADDNPI^XUSNPI("Individual_ID",DA,XUSNPI,$$NOW^XLFDT(),1) ;add NPI 87 I XUS1>0,$D(KEYS) F XUS2=1:1 S Y=$P(KEYS,",",XUS2) Q:'$L(Y) D 88 . S %=$$ADD^XQKEY(XUS1,Y) I '% W !,"Key '",Y,"' not allocated" 89 I XUS1>0 D CALL^XUSERP(+XUS1,1) ;XQOR add 90 AX Q XUS1 91 ; 92 REPRINT ;Reprint letter 93 S DA=+$$LOOKUP^XUSER G EXIT:DA'>0 94 D LETTER(DA) 95 G EXIT 96 ; 97 LETTER(XUN,ASK) ;Print access letter 98 Q:'$G(XUN) 99 N DIWF,FR,TO,BY,DIR,XUTEXT 100 S XUTEXT=$$GET^XUPARAM("XUSER COMPUTER ACCOUNT","N"),XUTEXT=$O(^DIC(9.2,"B",XUTEXT,0)) 101 S DIR(0)="Y",DIR("A")="Print User Account Access Letter" 102 I XUTEXT>0 S Y=1 D:$G(ASK) ^DIR I Y=1 D 103 . S (XUU,XUU2)="________",DIWF="^DIC(9.2,XUTEXT,1,",DIWF(1)=200,FR=XUN,TO=XUN,BY="NUMBER" D EN2^DIWF 104 . Q 105 Q -
WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPI.m
r613 r623 1 XUSNPI ;OAK_BP/BDT - NATIONAL PROVIDER IDENTIFIER ;6/3/08 13:51 2 ;;8.0;KERNEL;**410,416,480**; July 10, 1995;Build 38 3 ;;Per VHA Directive 2004-038, this routine should not be modified 4 ADDNPI(XUSQI,XUSIEN,XUSNPI,XUSDATE,XUSTATUS) ; 5 ;;============================================================== 6 ;; Update the Effective Date, Status & NPI trio. 7 ;; XUSQI : Qualified Identifier, Required. For examble: Individual_ID Or Organization_ID 8 ;; XUSIEN : Internal Entry Number. Required. 9 ;; XUSNPI : National Provider Identifier. Required. 10 ;; XUSDATE : Active Date. Required. 11 ;; 12 ;; If successful, return XUSRTN = IEN of new 42 sub-file entry. 13 ;; Else return XUSRTN = "-1^ErrorMessage". 14 ;; ============================================================= 15 ; 16 ; Check valid inputs. 17 N XUSROOT,XUSFNB 18 S XUSROOT=$$GET^XPAR("PKG.KERNEL","XUSNPI QUALIFIED IDENTIFIER",XUSQI) 19 I $E(XUSROOT)'="^" S XUSROOT="^"_XUSROOT 20 I XUSROOT="^" Q "-1^Invalid Qualified Identifier" 21 I $$GLCK(XUSROOT)'>0 Q "-1^Invalid Qualified Identifier" 22 S XUSFNB=+$P(XUSROOT,"(",2) 23 I 'XUSFNB Q "-1^No File #" 24 S XUSFNB=XUSFNB_".42" 25 I $G(XUSIEN)'>0 Q "-1^Invalid IEN" 26 ;I (XUSIEN?.N)=0 Q "-1^Invalid IEN" 27 I ((XUSIEN?.N)!(XUSIEN?.N1"."1N.N))=0 Q "-1^Invalid IEN" 28 N XUIENCK S XUIENCK=XUSROOT_XUSIEN_","_0_")" I '$D(@XUIENCK) Q "-1^Invalid IEN" 29 I '$$CHKDGT(XUSNPI) Q "-1^Invalid NPI" 30 I '$$CHKDT(XUSQI,XUSIEN,XUSDATE) Q "-1^Invalid Effective Date" 31 I $G(XUSTATUS)="" S XUSTATUS=1 32 I (XUSTATUS'=0),(XUSTATUS'=1) Q "-1^Invalid Status" 33 N CHNPI S CHNPI=$$CHKDGT^XUSNPIE1(XUSNPI,XUSIEN,XUSQI) ; check if NPI is being used. 34 I CHNPI'=1 Q "-1^The NPI is being used." 35 ; 36 ;------------------------------------------------------------------ 37 N ZZ,XUSRTN,ERRMSG,XUSX S ERRMSG="" 38 S XUSX=XUSROOT_XUSIEN_","_"""NPISTATUS"""_")" 39 ; Update Effective Date #42 multiple fields 40 S XUSFNB=$P(XUSROOT,"(",2) 41 S XUSFNB=+$P(XUSFNB,",") I XUSFNB S XUSFNB=XUSFNB_".042" 42 S ZZ(1,XUSFNB,"+2,"_XUSIEN_",",.01)=XUSDATE 43 S ZZ(1,XUSFNB,"+2,"_XUSIEN_",",.02)=XUSTATUS 44 S ZZ(1,XUSFNB,"+2,"_XUSIEN_",",.03)=XUSNPI 45 D UPDATE^DIE("","ZZ(1)",,ERRMSG) 46 I $L(ERRMSG) Q "-1^"_$G(ERRMSG) 47 S XUSX=XUSROOT_XUSIEN_","_"""NPISTATUS"""_","_"""B"""_","_XUSDATE_","_"""A"""_")" 48 S XUSRTN=$O(@XUSX,-1) 49 I '+XUSRTN Q "-1^No entry add" 50 Q XUSRTN 51 ; 52 NPI(XUSQI,XUSIEN,XUSDATE) ; Retrieve the NPI value for a qualified identifier entity. 53 ;;============================================================== 54 ;; XUSQI : Qualified Identifier, Required. For examble: Individual_ID Or Organization_ID 55 ;; XUSIEN : Internal Entry Number of file #4 or #200. Required. 56 ;; XUSDATE : Active Date. Not Required. Default: 'Today'. 57 ;; 58 ;; If current NPI exists, return XUSRTN = 'NPI^EffectiveDate^Status' 59 ;; If invalid XUSQI or XUSIEN, return '-1^ErrorMessage' 60 ;; Else return 0 61 ;; ============================================================= 62 ; check valid inputs 63 I $G(XUSIEN)'>0 Q "-1^Invalid IEN" 64 ;I (XUSIEN?.N)=0 Q "-1^Invalid IEN" 65 I ((XUSIEN?.N)!(XUSIEN?.N1"."1N.N))=0 Q "-1^Invalid IEN" 66 I $G(XUSDATE)="" S XUSDATE=$$NOW^XLFDT 67 N X,Y,%DT S %DT="T",X=XUSDATE D ^%DT I Y'=XUSDATE Q "-1^Invalid Effective Date" 68 ;----------------------------------- 69 N XUSDA,XUSI,XUSRTN,XUSROOT,XUSX,XUSTAT S (XUSDA,XUSRTN)="",XUSTAT="Inactive" 70 ; get global from Parameter file base on Qualified Identifier. 71 S XUSROOT=$$GET^XPAR("PKG.KERNEL","XUSNPI QUALIFIED IDENTIFIER",XUSQI) 72 I $E(XUSROOT)'="^" S XUSROOT="^"_XUSROOT 73 I XUSROOT="^" Q "-1^Invalid Qualified Identifier" 74 N XUIENCK S XUIENCK=XUSROOT_XUSIEN_","_0_")" I '$D(@XUIENCK) Q "-1^Invalid IEN" 75 I $$GLCK(XUSROOT)'>0 Q "-1^Invalid Qualified Identifier" 76 S XUSROOT=XUSROOT_XUSIEN_","_"""NPISTATUS""" 77 S XUSX=XUSROOT_")" I '$D(@XUSX) Q "-1^No NPI found" 78 S XUSI=0 F S XUSI=$O(@(XUSROOT_","_"""B"""_","_XUSI_")")) Q:XUSI>XUSDATE!'XUSI 79 I 'XUSI S XUSX=XUSROOT_","_"""B"""_","_"""A"""_")",XUSDA=$O(@XUSX,-1) 80 I XUSI>XUSDATE S XUSX=XUSROOT_","_"""B"""_","_XUSI_")",XUSDA=$O(@(XUSX),-1) 81 I XUSDA="" Q 0 82 S XUSDA=XUSROOT_","_"""B"""_","_XUSDA_","_"""A"""_")",XUSDA=$O(@XUSDA,-1) 83 S XUSRTN=XUSROOT_","_XUSDA_","_0_")" 84 I '$D(@XUSRTN) Q "-1^Invalid IEN" 85 I $P($G(@XUSRTN),"^",2)=1 S XUSTAT="Active" 86 Q $P($G(@XUSRTN),"^",3)_"^"_$P($G(@XUSRTN),"^",1)_"^"_XUSTAT 87 ; 88 QI(XUSNPI) ; Retrieve the ALL qualified indentifier entity for an NPI value. 89 ;;================================================ 90 ;; XUSNPI : National Provider Identifier. Required 91 ;; 92 ;; If qualified identified entity exists, return 93 ;; 'QualifiedIdentifier^IEN^EffectiveDate^Status;' 94 ;; If more than one records found, they are separated by ";" 95 ;; Else return 0 96 ;;================================================ 97 ; check valid NPI 98 I '$$CHKDGT(XUSNPI) Q "0^Invalid NPI" 99 N ZZ 100 D GETLST^XPAR(.ZZ,"PKG.KERNEL","XUSNPI QUALIFIED IDENTIFIER") 101 I ZZ'>0 Q 0 102 N XUSI,XUSIEN,XUSROOT,XUSQT,XUSX,XUSRTN,XUSRTN1 S (XUSQT,XUSRTN)=0,XUSRTN1="" 103 S XUSI=0 F S XUSI=$O(ZZ(XUSI)) Q:'XUSI D 104 . S XUSROOT=$P(ZZ(XUSI),"^",2),XUSROOT="^"_XUSROOT 105 . I $$GLCK(XUSROOT)'>0 Q ;check valid global root 106 . I $E(XUSNPI,1,1)=0 S XUSNPI=""""_XUSNPI_"""" 107 . S XUSX=XUSROOT_"""NPI42"""_","_XUSNPI_")" Q:'$D(@XUSX) 108 . S XUSIEN=0 F S XUSX=XUSROOT_"""NPI42"""_","_XUSNPI_","_XUSIEN_")",XUSIEN=$O(@XUSX) Q:XUSIEN'>0 D 109 . . S XUSRTN=$$SRCHNPI(XUSROOT,XUSIEN,XUSNPI) 110 . . I +XUSRTN S XUSRTN1=XUSRTN1_$P(ZZ(XUSI),"^")_"^"_XUSRTN_";",XUSQT=XUSQT+1 111 I XUSRTN1="" S XUSRTN1=0 112 Q XUSRTN1 113 ; 114 GLCK(XUSROOT) ; check valid global root 115 N XUFNB,ZZ 116 I $G(XUSROOT)="" Q 0 117 S XUFNB=$P(XUSROOT,"(",2),XUFNB=$P(XUFNB,",") 118 D FILE^DID(XUFNB,"","GLOBAL NAME","ZZ") 119 Q (XUSROOT=$G(ZZ("GLOBAL NAME"))) 120 ; 121 SRCHNPI(XUSROOT,XUSIEN,XUSNPI) ; 122 I $G(XUSIEN)'>0 Q 0 123 I (XUSIEN?.N)=0 Q 0 124 N XUSX,XUSRTN S XUSRTN=0 125 I $E(XUSNPI,1,1)=0 S XUSNPI=""""_XUSNPI_"""" 126 S XUSX=XUSROOT_XUSIEN_","_"""NPISTATUS"""_","_"""C"""_","_XUSNPI_")" 127 I '$D(@XUSX) Q 0 128 S XUSX=XUSROOT_XUSIEN_","_"""NPISTATUS"""_","_"""C"""_","_XUSNPI_","_"""A"""_")" 129 S XUSRTN=$O(@XUSX,-1) 130 I '+XUSRTN Q 0 131 S XUSX=XUSROOT_XUSIEN_","_"""NPISTATUS"""_","_XUSRTN_","_0_")" 132 I '$D(@XUSX) Q 0 133 S XUSRTN=$G(@XUSX) I XUSRTN S XUSRTN=XUSIEN_"^"_$P(XUSRTN,"^")_"^"_$P(XUSRTN,"^",2) 134 I $P(XUSRTN,"^",3)=1 S $P(XUSRTN,"^",3)="Active" 135 I $P(XUSRTN,"^",3)=0 S $P(XUSRTN,"^",3)="Inactive" 136 Q XUSRTN 137 ; 138 CHKDGT(XUSNPI) ; 139 ; Function to validate the format of an NPI number. It checks the 140 ; length of the number, whether the NPI is numeric, and whether 141 ; the check digit is valid. 142 ; 143 ; Input parameter: 144 ; NPI - 10-digit NPI number to validate. 145 ; 146 ; Output parameter: 147 ; Boolean value indicating whether the NPI has a valid format 148 ; 149 ; NPI must be 10 digits long. 150 I XUSNPI'?10N Q 0 151 Q $E(XUSNPI,10)=$$CKDIGIT($E(XUSNPI,1,9)) 152 ; 153 CKDIGIT(XUSNPI) ; 154 ; Function to calculate and return the check digit of an NPI. 155 ; The check digit is calculated using the Luhn Formula for 156 ; Modulus 10 "double-add-double" Check Digit. A value of 24 is 157 ; added to the total to account for the implied USA (80840) prefix. 158 ; 159 N XUSCTOT,XUSCN,XUSCDIG,XUSI 160 S XUSCTOT=24 161 F XUSI=9:-2:1 S XUSCN=2*$E(XUSNPI,XUSI),XUSCTOT=XUSCTOT+$E(XUSCN)+$E(XUSCN,2)+$E(XUSNPI,XUSI-1) 162 S XUSCDIG=150-XUSCTOT 163 Q $E(XUSCDIG,$L(XUSCDIG)) 164 ; 165 CHKDT(XUSQI,XUSIEN,XUSDATE) ; Check Date 166 ;;============================================================================ 167 ;; XUSQI : Qualified Identifier. Required. For examble: "Individual_ID" 168 ;; XUSIEN : Internal Entry Number. Required. 169 ;; XUSDATE : The Effective Date value to test. Must be FM date. Required. 170 ;; 171 ;; If input passes date comparison, return 1. 172 ;; Else return 0. 173 ;;============================================================================ 174 ; 175 I $G(XUSIEN)'>0 Q "0^Invalid IEN." 176 ;I (XUSIEN?.N)=0 Q "0^Invalid IEN." 177 I ((XUSIEN?.N)!(XUSIEN?.N1"."1N.N))=0 Q "-1^Invalid IEN" 178 N X,Y,%DT S %DT="T",X=$G(XUSDATE) D ^%DT I Y'=XUSDATE Q "0^Invalid Effective Date. Must be FM Date/Time." 179 ;----------------------------------- 180 N XUSROOT,XUSDA 181 N XUSCRDT S XUSCRDT=$$NOW^XLFDT I XUSDATE>XUSCRDT Q 0 182 ; get global from Parameter file base on Qualified Identifier. 183 S XUSROOT=$$GET^XPAR("PKG.KERNEL","XUSNPI QUALIFIED IDENTIFIER",XUSQI) 184 I $E(XUSROOT)'="^" S XUSROOT="^"_XUSROOT 185 I XUSROOT="^" Q "0^Invalid Qualified Identifier." 186 I $$GLCK(XUSROOT)'>0 Q "-1^Invalid Qualified Identifier" 187 N XUIENCK S XUIENCK=XUSROOT_XUSIEN_","_0_")" I $D(@XUIENCK)'>0 Q "0^Invalid IEN." 188 S XUSROOT=XUSROOT_XUSIEN_","_"""NPISTATUS"""_","_"""B"""_","_"""A"""_")",XUSDA=$O(@XUSROOT,-1) 189 Q (XUSDATE'<XUSDA) 190 ; 191 GETRLNPI(XUSIEN) ; Return field indicating blanket release of NPI 192 ;; XUSIEN : Internal Entry Number of person in file 200. Required 193 ;; Output: -1^error message or contents of AUTHORIZE RELEASE OF NPI field. 194 S XUSIEN=+$G(XUSIEN) I $G(^VA(200,XUSIEN,0))="" Q "-1^Invalid IEN" 195 N X 196 S X=$$NPI^XUSNPI("Individual_ID",XUSIEN) 197 I (X'>0)!($P(X,U,3)'="Active") Q "-1^User has no active NPI" 198 S X=$P($G(^VA(200,XUSIEN,"NPI")),U,3) 199 S:X="" X=0 200 Q X 201 ; 1 XUSNPI ;OAK_BP/BDT - NATIONAL PROVIDER IDENTIFIER; 8/10/06 2 ;;8.0;KERNEL;**410,416**; July 10, 1997;Build 5 3 ;; 4 ADDNPI(XUSQI,XUSIEN,XUSNPI,XUSDATE,XUSTATUS) ; 5 ;;============================================================== 6 ;; Update the Effective Date, Status & NPI trio. 7 ;; XUSQI : Qualified Identifier, Required. For examble: Individual_ID Or Organization_ID 8 ;; XUSIEN : Internal Entry Number. Required. 9 ;; XUSNPI : National Provider Identifier. Required. 10 ;; XUSDATE : Active Date. Required. 11 ;; 12 ;; If successful, return XUSRTN = IEN of new 42 sub-file entry. 13 ;; Else return XUSRTN = "-1^ErrorMessage". 14 ;; ============================================================= 15 ; 16 ; Check valid inputs. 17 N XUSROOT,XUSFNB 18 S XUSROOT=$$GET^XPAR("PKG.KERNEL","XUSNPI QUALIFIED IDENTIFIER",XUSQI) 19 I $E(XUSROOT)'="^" S XUSROOT="^"_XUSROOT 20 I XUSROOT="^" Q "-1^Invalid Qualified Identifier" 21 I $$GLCK(XUSROOT)'>0 Q "-1^Invalid Qualified Identifier" 22 S XUSFNB=+$P(XUSROOT,"(",2) 23 I 'XUSFNB Q "-1^No File #" 24 S XUSFNB=XUSFNB_".42" 25 I $G(XUSIEN)'>0 Q "-1^Invalid IEN" 26 ;I (XUSIEN?.N)=0 Q "-1^Invalid IEN" 27 I ((XUSIEN?.N)!(XUSIEN?.N1"."1N.N))=0 Q "-1^Invalid IEN" 28 N XUIENCK S XUIENCK=XUSROOT_XUSIEN_","_0_")" I '$D(@XUIENCK) Q "-1^Invalid IEN" 29 I '$$CHKDGT(XUSNPI) Q "-1^Invalid NPI" 30 I '$$CHKDT(XUSQI,XUSIEN,XUSDATE) Q "-1^Invalid Effective Date" 31 I $G(XUSTATUS)="" S XUSTATUS=1 32 I (XUSTATUS'=0),(XUSTATUS'=1) Q "-1^Invalid Status" 33 N CHNPI S CHNPI=$$CHKDGT^XUSNPIE1(XUSNPI,XUSIEN,XUSQI) ; check if NPI is being used. 34 I CHNPI'=1 Q "-1^The NPI is being used." 35 ; 36 ;------------------------------------------------------------------ 37 N ZZ,XUSRTN,ERRMSG,XUSX S ERRMSG="" 38 S XUSX=XUSROOT_XUSIEN_","_"""NPISTATUS"""_")" 39 ; Update Effective Date #42 multiple fields 40 S XUSFNB=$P(XUSROOT,"(",2) 41 S XUSFNB=+$P(XUSFNB,",") I XUSFNB S XUSFNB=XUSFNB_".042" 42 S ZZ(1,XUSFNB,"+2,"_XUSIEN_",",.01)=XUSDATE 43 S ZZ(1,XUSFNB,"+2,"_XUSIEN_",",.02)=XUSTATUS 44 S ZZ(1,XUSFNB,"+2,"_XUSIEN_",",.03)=XUSNPI 45 D UPDATE^DIE("","ZZ(1)",,ERRMSG) 46 I $L(ERRMSG) Q "-1^"_$G(ERRMSG) 47 S XUSX=XUSROOT_XUSIEN_","_"""NPISTATUS"""_","_"""B"""_","_XUSDATE_","_"""A"""_")" 48 S XUSRTN=$O(@XUSX,-1) 49 I '+XUSRTN Q "-1^No entry add" 50 Q XUSRTN 51 ; 52 NPI(XUSQI,XUSIEN,XUSDATE) ; Retrieve the NPI value for a qualified identifier entity. 53 ;;============================================================== 54 ;; XUSQI : Qualified Identifier, Required. For examble: Individual_ID Or Organization_ID 55 ;; XUSIEN : Internal Entry Number of file #4 or #200. Required. 56 ;; XUSDATE : Active Date. Not Required. Default: 'Today'. 57 ;; 58 ;; If current NPI exists, return XUSRTN = 'NPI^EffectiveDate^Status' 59 ;; If invalid XUSQI or XUSIEN, return '-1^ErrorMessage' 60 ;; Else return 0 61 ;; ============================================================= 62 ; check valid inputs 63 I $G(XUSIEN)'>0 Q "-1^Invalid IEN" 64 ;I (XUSIEN?.N)=0 Q "-1^Invalid IEN" 65 I ((XUSIEN?.N)!(XUSIEN?.N1"."1N.N))=0 Q "-1^Invalid IEN" 66 I $G(XUSDATE)="" S XUSDATE=$$NOW^XLFDT 67 N X,Y,%DT S %DT="T",X=XUSDATE D ^%DT I Y'=XUSDATE Q "-1^Invalid Effective Date" 68 ;----------------------------------- 69 N XUSDA,XUSI,XUSRTN,XUSROOT,XUSX,XUSTAT S (XUSDA,XUSRTN)="",XUSTAT="Inactive" 70 ; get global from Parameter file base on Qualified Identifier. 71 S XUSROOT=$$GET^XPAR("PKG.KERNEL","XUSNPI QUALIFIED IDENTIFIER",XUSQI) 72 I $E(XUSROOT)'="^" S XUSROOT="^"_XUSROOT 73 I XUSROOT="^" Q "-1^Invalid Qualified Identifier" 74 N XUIENCK S XUIENCK=XUSROOT_XUSIEN_","_0_")" I '$D(@XUIENCK) Q "-1^Invalid IEN" 75 I $$GLCK(XUSROOT)'>0 Q "-1^Invalid Qualified Identifier" 76 S XUSROOT=XUSROOT_XUSIEN_","_"""NPISTATUS""" 77 S XUSX=XUSROOT_")" I '$D(@XUSX) Q "-1^No NPI found" 78 S XUSI=0 F S XUSI=$O(@(XUSROOT_","_"""B"""_","_XUSI_")")) Q:XUSI>XUSDATE!'XUSI 79 I 'XUSI S XUSX=XUSROOT_","_"""B"""_","_"""A"""_")",XUSDA=$O(@XUSX,-1) 80 I XUSI>XUSDATE S XUSX=XUSROOT_","_"""B"""_","_XUSI_")",XUSDA=$O(@(XUSX),-1) 81 I XUSDA="" Q 0 82 S XUSDA=XUSROOT_","_"""B"""_","_XUSDA_","_"""A"""_")",XUSDA=$O(@XUSDA,-1) 83 S XUSRTN=XUSROOT_","_XUSDA_","_0_")" 84 I '$D(@XUSRTN) Q "-1^Invalid IEN" 85 I $P($G(@XUSRTN),"^",2)=1 S XUSTAT="Active" 86 Q $P($G(@XUSRTN),"^",3)_"^"_$P($G(@XUSRTN),"^",1)_"^"_XUSTAT 87 ; 88 QI(XUSNPI) ; Retrieve the ALL qualified indentifier entity for an NPI value. 89 ;;================================================ 90 ;; XUSNPI : National Provider Identifier. Required 91 ;; 92 ;; If qualified identified entity exists, return 93 ;; 'QualifiedIdentifier^IEN^EffectiveDate^Status;' 94 ;; If more than one records found, they are separated by ";" 95 ;; Else return 0 96 ;;================================================ 97 ; check valid NPI 98 I '$$CHKDGT(XUSNPI) Q "0^Invalid NPI" 99 N ZZ 100 D GETLST^XPAR(.ZZ,"PKG.KERNEL","XUSNPI QUALIFIED IDENTIFIER") 101 I ZZ'>0 Q 0 102 N XUSI,XUSIEN,XUSROOT,XUSQT,XUSX,XUSRTN,XUSRTN1 S (XUSQT,XUSRTN)=0,XUSRTN1="" 103 S XUSI=0 F S XUSI=$O(ZZ(XUSI)) Q:'XUSI D 104 . S XUSROOT=$P(ZZ(XUSI),"^",2),XUSROOT="^"_XUSROOT 105 . I $$GLCK(XUSROOT)'>0 Q ;check valid global root 106 . I $E(XUSNPI,1,1)=0 S XUSNPI=""""_XUSNPI_"""" 107 . S XUSX=XUSROOT_"""NPI42"""_","_XUSNPI_")" Q:'$D(@XUSX) 108 . S XUSIEN=0 F S XUSX=XUSROOT_"""NPI42"""_","_XUSNPI_","_XUSIEN_")",XUSIEN=$O(@XUSX) Q:XUSIEN'>0 D 109 . . S XUSRTN=$$SRCHNPI(XUSROOT,XUSIEN,XUSNPI) 110 . . I +XUSRTN S XUSRTN1=XUSRTN1_$P(ZZ(XUSI),"^")_"^"_XUSRTN_";",XUSQT=XUSQT+1 111 I XUSRTN1="" S XUSRTN1=0 112 Q XUSRTN1 113 ; 114 GLCK(XUSROOT) ; check valid global root 115 N XUFNB,ZZ 116 I $G(XUSROOT)="" Q 0 117 S XUFNB=$P(XUSROOT,"(",2),XUFNB=$P(XUFNB,",") 118 D FILE^DID(XUFNB,"","GLOBAL NAME","ZZ") 119 Q (XUSROOT=$G(ZZ("GLOBAL NAME"))) 120 ; 121 SRCHNPI(XUSROOT,XUSIEN,XUSNPI) ; 122 I $G(XUSIEN)'>0 Q 0 123 I (XUSIEN?.N)=0 Q 0 124 N XUSX,XUSRTN S XUSRTN=0 125 I $E(XUSNPI,1,1)=0 S XUSNPI=""""_XUSNPI_"""" 126 S XUSX=XUSROOT_XUSIEN_","_"""NPISTATUS"""_","_"""C"""_","_XUSNPI_")" 127 I '$D(@XUSX) Q 0 128 S XUSX=XUSROOT_XUSIEN_","_"""NPISTATUS"""_","_"""C"""_","_XUSNPI_","_"""A"""_")" 129 S XUSRTN=$O(@XUSX,-1) 130 I '+XUSRTN Q 0 131 S XUSX=XUSROOT_XUSIEN_","_"""NPISTATUS"""_","_XUSRTN_","_0_")" 132 I '$D(@XUSX) Q 0 133 S XUSRTN=$G(@XUSX) I XUSRTN S XUSRTN=XUSIEN_"^"_$P(XUSRTN,"^")_"^"_$P(XUSRTN,"^",2) 134 I $P(XUSRTN,"^",3)=1 S $P(XUSRTN,"^",3)="Active" 135 I $P(XUSRTN,"^",3)=0 S $P(XUSRTN,"^",3)="Inactive" 136 Q XUSRTN 137 ; 138 CHKDGT(XUSNPI) ; 139 ; Function to validate the format of an NPI number. It checks the 140 ; length of the number, whether the NPI is numeric, and whether 141 ; the check digit is valid. 142 ; 143 ; Input parameter: 144 ; NPI - 10-digit NPI number to validate. 145 ; 146 ; Output parameter: 147 ; Boolean value indicating whether the NPI has a valid format 148 ; 149 ; NPI must be 10 digits long. 150 I XUSNPI'?10N Q 0 151 Q $E(XUSNPI,10)=$$CKDIGIT($E(XUSNPI,1,9)) 152 ; 153 CKDIGIT(XUSNPI) ; 154 ; Function to calculate and return the check digit of an NPI. 155 ; The check digit is calculated using the Luhn Formula for 156 ; Modulus 10 "double-add-double" Check Digit. A value of 24 is 157 ; added to the total to account for the implied USA (80840) prefix. 158 ; 159 N XUSCTOT,XUSCN,XUSCDIG,XUSI 160 S XUSCTOT=24 161 F XUSI=9:-2:1 S XUSCN=2*$E(XUSNPI,XUSI),XUSCTOT=XUSCTOT+$E(XUSCN)+$E(XUSCN,2)+$E(XUSNPI,XUSI-1) 162 S XUSCDIG=150-XUSCTOT 163 Q $E(XUSCDIG,$L(XUSCDIG)) 164 ; 165 CHKDT(XUSQI,XUSIEN,XUSDATE) ; Check Date 166 ;;============================================================================ 167 ;; XUSQI : Qualified Identifier. Required. For examble: "Individual_ID" 168 ;; XUSIEN : Internal Entry Number. Required. 169 ;; XUSDATE : The Effective Date value to test. Must be FM date. Required. 170 ;; 171 ;; If input passes date comparison, return 1. 172 ;; Else return 0. 173 ;;============================================================================ 174 ; 175 I $G(XUSIEN)'>0 Q "0^Invalid IEN." 176 ;I (XUSIEN?.N)=0 Q "0^Invalid IEN." 177 I ((XUSIEN?.N)!(XUSIEN?.N1"."1N.N))=0 Q "-1^Invalid IEN" 178 N X,Y,%DT S %DT="T",X=$G(XUSDATE) D ^%DT I Y'=XUSDATE Q "0^Invalid Effective Date. Must be FM Date/Time." 179 ;----------------------------------- 180 N XUSROOT,XUSDA 181 N XUSCRDT S XUSCRDT=$$NOW^XLFDT I XUSDATE>XUSCRDT Q 0 182 ; get global from Parameter file base on Qualified Identifier. 183 S XUSROOT=$$GET^XPAR("PKG.KERNEL","XUSNPI QUALIFIED IDENTIFIER",XUSQI) 184 I $E(XUSROOT)'="^" S XUSROOT="^"_XUSROOT 185 I XUSROOT="^" Q "0^Invalid Qualified Identifier." 186 I $$GLCK(XUSROOT)'>0 Q "-1^Invalid Qualified Identifier" 187 N XUIENCK S XUIENCK=XUSROOT_XUSIEN_","_0_")" I $D(@XUIENCK)'>0 Q "0^Invalid IEN." 188 S XUSROOT=XUSROOT_XUSIEN_","_"""NPISTATUS"""_","_"""B"""_","_"""A"""_")",XUSDA=$O(@XUSROOT,-1) 189 Q (XUSDATE'<XUSDA) -
WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPIDA.m
r613 r623 1 XUSNPIDA ;FO-OAKLAND/JLI - SPECIFIED TAXONOMY VALUES FOR NPI RECIPIENTS ;4/8/08 18:18 2 ;;8.0;KERNEL;**420,410,480**;Jul 10, 1995;Build 38 3 ;;Per VHA Directive 2004-038, this routine should not be modified 4 Q 5 ; 6 CHKGLOB() ; returns global location of TAXONOMY values also rebuilds if they are missing 7 N I,STR,XUGLOB 8 S XUGLOB=$NA(^XTMP("NPIVALS")) 9 ; check for ;;; is to permit sites to add a ; to exclude some values not used at site 10 I '$D(@XUGLOB) F I=1:1 S STR=$T(@("VALUES+"_I_"^XUSNPIDA")) I STR'[";;;" S STR=$P(STR,";;",2) Q:STR="" S @XUGLOB@(STR)="" 11 S @XUGLOB@(0)=$$FMADD^XLFDT(DT,15) 12 Q XUGLOB 13 ; 14 VALUES ; 15 ;;101Y00000X 16 ;;101YA0400X 17 ;;101YM0800X 18 ;;101YP1600X 19 ;;101YP2500X 20 ;;101YS0200X 21 ;;103G00000X 22 ;;103GC0700X 23 ;;103T00000X 24 ;;103TA0400X 25 ;;103TA0700X 26 ;;103TB0200X 27 ;;103TC0700X 28 ;;103TC1900X 29 ;;103TC2200X 30 ;;103TE1000X 31 ;;103TE1100X 32 ;;103TF0000X 33 ;;103TF0200X 34 ;;103TH0100X 35 ;;103TM1700X 36 ;;103TM1800X 37 ;;103TP0814X 38 ;;103TP2700X 39 ;;103TP2701X 40 ;;103TR0400X 41 ;;103TS0200X 42 ;;103TW0100X 43 ;;104100000X 44 ;;1041C0700X 45 ;;1041S0200X 46 ;;111N00000X 47 ;;111NI0900X 48 ;;111NN0400X 49 ;;111NN1001X 50 ;;111NR0200X 51 ;;111NS0005X 52 ;;111NT0100X 53 ;;111NX0100X 54 ;;111NX0800X 55 ;;122300000X 56 ;;1223D0001X 57 ;;1223E0200X 58 ;;1223G0001X 59 ;;1223P0106X 60 ;;1223P0221X 61 ;;1223P0300X 62 ;;1223P0700X 63 ;;1223S0112X 64 ;;1223X0008X 65 ;;1223X0400X 66 ;;133V00000X 67 ;;133VN1004X 68 ;;133VN1005X 69 ;;133VN1006X 70 ;;152W00000X 71 ;;152WC0802X 72 ;;152WL0500X 73 ;;152WP0200X 74 ;;152WS0006X 75 ;;152WV0400X 76 ;;152WX0102X 77 ;;170100000X 78 ;;183500000X 79 ;;1835G0000X 80 ;;1835N0905X 81 ;;1835N1003X 82 ;;1835P1200X 83 ;;1835P1300X 84 ;;204C00000X 85 ;;204D00000X 86 ;;204E00000X 87 ;;204F00000X 88 ;;207K00000X 89 ;;207KA0200X 90 ;;207KI0005X 91 ;;207L00000X 92 ;;207LA0401X 93 ;;207LC0200X 94 ;;207LP2900X 95 ;;207N00000X 96 ;;207ND0101X 97 ;;207ND0900X 98 ;;207NI0002X 99 ;;207NP0225X 100 ;;207NS0135X 101 ;;207P00000X 102 ;;207PE0004X 103 ;;207PE0005X 104 ;;207PP0204X 105 ;;207PS0010X 106 ;;207PT0002X 107 ;;207Q00000X 108 ;;207QA0000X 109 ;;207QA0401X 110 ;;207QA0505X 111 ;;207QG0300X 112 ;;207QS0010X 113 ;;207R00000X 114 ;;207RA0000X 115 ;;207RA0201X 116 ;;207RA0401X 117 ;;207RC0000X 118 ;;207RC0001X 119 ;;207RC0200X 120 ;;207RE0101X 121 ;;207RG0100X 122 ;;207RG0300X 123 ;;207RH0000X 124 ;;207RH0003X 125 ;;207RI0001X 126 ;;207RI0008X 127 ;;207RI0011X 128 ;;207RI0200X 129 ;;207RM1200X 130 ;;207RN0300X 131 ;;207RP1001X 132 ;;207RR0500X 133 ;;207RS0010X 134 ;;207RX0202X 135 ;;207SC0300X 136 ;;207SG0201X 137 ;;207SG0202X 138 ;;207SG0203X 139 ;;207SG0205X 140 ;;207SM0001X 141 ;;207T00000X 142 ;;207U00000X 143 ;;207UN0901X 144 ;;207UN0902X 145 ;;207UN0903X 146 ;;207V00000X 147 ;;207VC0200X 148 ;;207VE0102X 149 ;;207VG0400X 150 ;;207VM0101X 151 ;;207VX0000X 152 ;;207VX0201X 153 ;;207W00000X 154 ;;207X00000X 155 ;;207XS0106X 156 ;;207XS0114X 157 ;;207XS0117X 158 ;;207XX0004X 159 ;;207XX0005X 160 ;;207XX0801X 161 ;;207Y00000X 162 ;;207YP0228X 163 ;;207YS0123X 164 ;;207YX0007X 165 ;;207YX0602X 166 ;;207YX0901X 167 ;;207YX0905X 168 ;;207ZB0001X 169 ;;207ZC0500X 170 ;;207ZD0900X 171 ;;207ZF0201X 172 ;;207ZH0000X 173 ;;207ZI0100X 174 ;;207ZM0300X 175 ;;207ZN0500X 176 ;;207ZP0007X 177 ;;207ZP0101X 178 ;;207ZP0102X 179 ;;207ZP0104X 180 ;;207ZP0105X 181 ;;207ZP0213X 182 ;;208000000X 183 ;;2080A0000X 184 ;;2080I0007X 185 ;;2080N0001X 186 ;;2080P0006X 187 ;;2080P0008X 188 ;;2080P0201X 189 ;;2080P0202X 190 ;;2080P0203X 191 ;;2080P0204X 192 ;;2080P0205X 193 ;;2080P0206X 194 ;;2080P0207X 195 ;;2080P0208X 196 ;;2080P0210X 197 ;;2080P0214X 198 ;;2080P0216X 199 ;;2080S0010X 200 ;;2080T0002X 201 ;;208100000X 202 ;;2081P0004X 203 ;;2081P0010X 204 ;;2081P2900X 205 ;;2081S0010X 206 ;;208200000X 207 ;;2082S0099X 208 ;;2082S0105X 209 ;;2083A0100X 210 ;;2083P0011X 211 ;;2083P0500X 212 ;;2083P0901X 213 ;;2083S0010X 214 ;;2083T0002X 215 ;;2083X0100X 216 ;;2084A0401X 217 ;;2084F0202X 218 ;;2084N0400X 219 ;;2084N0402X 220 ;;2084N0600X 221 ;;2084P0005X 222 ;;2084P0800X 223 ;;2084P0802X 224 ;;2084P0804X 225 ;;2084P0805X 226 ;;2084P2900X 227 ;;2084S0010X 228 ;;2084V0102X 229 ;;2085B0100X 230 ;;2085N0700X 231 ;;2085N0904X 232 ;;2085P0229X 233 ;;2085R0001X 234 ;;2085R0202X 235 ;;2085R0203X 236 ;;2085R0204X 237 ;;2085R0205X 238 ;;2085U0001X 239 ;;208600000X 240 ;;2086S0102X 241 ;;2086S0105X 242 ;;2086S0120X 243 ;;2086S0122X 244 ;;2086S0127X 245 ;;2086S0129X 246 ;;2086X0206X 247 ;;208800000X 248 ;;208C00000X 249 ;;208D00000X 250 ;;208G00000X 251 ;;208M00000X 252 ;;208U00000X 253 ;;208VP0000X 254 ;;208VP0014X 255 ;;209800000X 256 ;;213E00000X 257 ;;213EG0000X 258 ;;213EP0504X 259 ;;213EP1101X 260 ;;213ER0200X 261 ;;213ES0000X 262 ;;213ES0103X 263 ;;213ES0131X 264 ;;225100000X 265 ;;2251C2600X 266 ;;2251E1200X 267 ;;2251E1300X 268 ;;2251G0304X 269 ;;2251H1200X 270 ;;2251H1300X 271 ;;2251N0400X 272 ;;2251P0200X 273 ;;2251S0007X 274 ;;2251X0800X 275 ;;225X00000X 276 ;;225XE1200X 277 ;;225XH1200X 278 ;;225XH1300X 279 ;;225XN1300X 280 ;;225XP0200X 281 ;;225XR0403X 282 ;;231H00000X 283 ;;231HA2400X 284 ;;231HA2500X 285 ;;237600000X 286 ;;363A00000X 287 ;;363AM0700X 288 ;;363AS0400X 289 ;;363L00000X 290 ;;363LA2100X 291 ;;363LA2200X 292 ;;363LC0200X 293 ;;363LC1500X 294 ;;363LF0000X 295 ;;363LG0600X 296 ;;363LN0000X 297 ;;363LN0005X 298 ;;363LP0200X 299 ;;363LP0222X 300 ;;363LP0808X 301 ;;363LP1700X 302 ;;363LP2300X 303 ;;363LS0200X 304 ;;363LW0102X 305 ;;363LX0001X 306 ;;363LX0106X 307 ;;364S00000X 308 ;;364SA2100X 309 ;;364SA2200X 310 ;;364SC0200X 311 ;;364SC1501X 312 ;;364SC2300X 313 ;;364SE0003X 314 ;;364SE1400X 315 ;;364SF0001X 316 ;;364SG0600X 317 ;;364SH0200X 318 ;;364SH1100X 319 ;;364SI0800X 320 ;;364SL0600X 321 ;;364SM0705X 322 ;;364SN0000X 323 ;;364SN0800X 324 ;;364SP0200X 325 ;;364SP0807X 326 ;;364SP0808X 327 ;;364SP0809X 328 ;;364SP0810X 329 ;;364SP0811X 330 ;;364SP0812X 331 ;;364SP0813X 332 ;;364SP1700X 333 ;;364SP2800X 334 ;;364SR0400X 335 ;;364SS0200X 336 ;;364ST0500X 337 ;;364SW0102X 338 ;;364SX0106X 339 ;;364SX0200X 340 ;;364SX0204X 341 ;;367500000X 342 ;;367A00000X 343 ;;367H00000X 344 ;;390200000X 345 ;; 1 XUSNPIDA ;FO-OAKLAND/JLI - SPECIFIED TAXONOMY VALUES FOR NPI RECIPIENTS ;8/22/06 11:37 2 ;;8.0;KERNEL;**420,410**;Jul 10, 1995;Build 27 3 Q 4 ; 5 CHKGLOB() ; returns global location of TAXONOMY values also rebuilds if they are missing 6 N I,STR,XUGLOB 7 S XUGLOB=$NA(^XTMP("NPIVALS")) 8 ; check for ;;; is to permit sites to add a ; to exclude some values not used at site 9 I '$D(@XUGLOB) F I=1:1 S STR=$T(@("VALUES+"_I_"^XUSNPIDA")) I STR'[";;;" S STR=$P(STR,";;",2) Q:STR="" S @XUGLOB@(STR)="" 10 S @XUGLOB@(0)=$$FMADD^XLFDT(DT,15) 11 Q XUGLOB 12 ; 13 VALUES ; 14 ;;101Y00000X 15 ;;101YA0400X 16 ;;101YM0800X 17 ;;101YP1600X 18 ;;101YP2500X 19 ;;101YS0200X 20 ;;103G00000X 21 ;;103GC0700X 22 ;;103T00000X 23 ;;103TA0400X 24 ;;103TA0700X 25 ;;103TB0200X 26 ;;103TC0700X 27 ;;103TC1900X 28 ;;103TC2200X 29 ;;103TE1000X 30 ;;103TE1100X 31 ;;103TF0000X 32 ;;103TF0200X 33 ;;103TH0100X 34 ;;103TM1700X 35 ;;103TM1800X 36 ;;103TP0814X 37 ;;103TP2700X 38 ;;103TP2701X 39 ;;103TR0400X 40 ;;103TS0200X 41 ;;103TW0100X 42 ;;104100000X 43 ;;1041C0700X 44 ;;1041S0200X 45 ;;111N00000X 46 ;;111NI0900X 47 ;;111NN0400X 48 ;;111NN1001X 49 ;;111NR0200X 50 ;;111NS0005X 51 ;;111NT0100X 52 ;;111NX0100X 53 ;;111NX0800X 54 ;;122300000X 55 ;;1223D0001X 56 ;;1223E0200X 57 ;;1223G0001X 58 ;;1223P0106X 59 ;;1223P0221X 60 ;;1223P0300X 61 ;;1223P0700X 62 ;;1223S0112X 63 ;;1223X0008X 64 ;;1223X0400X 65 ;;133V00000X 66 ;;133VN1004X 67 ;;133VN1005X 68 ;;133VN1006X 69 ;;152W00000X 70 ;;152WC0802X 71 ;;152WL0500X 72 ;;152WP0200X 73 ;;152WS0006X 74 ;;152WV0400X 75 ;;152WX0102X 76 ;;170100000X 77 ;;183500000X 78 ;;1835G0000X 79 ;;1835N0905X 80 ;;1835N1003X 81 ;;1835P1200X 82 ;;1835P1300X 83 ;;204C00000X 84 ;;204D00000X 85 ;;204E00000X 86 ;;204F00000X 87 ;;207K00000X 88 ;;207KA0200X 89 ;;207KI0005X 90 ;;207L00000X 91 ;;207LA0401X 92 ;;207LC0200X 93 ;;207LP2900X 94 ;;207N00000X 95 ;;207ND0101X 96 ;;207ND0900X 97 ;;207NI0002X 98 ;;207NP0225X 99 ;;207NS0135X 100 ;;207P00000X 101 ;;207PE0004X 102 ;;207PE0005X 103 ;;207PP0204X 104 ;;207PS0010X 105 ;;207PT0002X 106 ;;207Q00000X 107 ;;207QA0000X 108 ;;207QA0401X 109 ;;207QA0505X 110 ;;207QG0300X 111 ;;207QS0010X 112 ;;207R00000X 113 ;;207RA0000X 114 ;;207RA0201X 115 ;;207RA0401X 116 ;;207RC0000X 117 ;;207RC0001X 118 ;;207RC0200X 119 ;;207RE0101X 120 ;;207RG0100X 121 ;;207RG0300X 122 ;;207RH0000X 123 ;;207RH0003X 124 ;;207RI0001X 125 ;;207RI0008X 126 ;;207RI0011X 127 ;;207RI0200X 128 ;;207RM1200X 129 ;;207RN0300X 130 ;;207RP1001X 131 ;;207RR0500X 132 ;;207RS0010X 133 ;;207RX0202X 134 ;;207SC0300X 135 ;;207SG0201X 136 ;;207SG0202X 137 ;;207SG0203X 138 ;;207SG0205X 139 ;;207SM0001X 140 ;;207T00000X 141 ;;207U00000X 142 ;;207UN0901X 143 ;;207UN0902X 144 ;;207UN0903X 145 ;;207V00000X 146 ;;207VC0200X 147 ;;207VE0102X 148 ;;207VG0400X 149 ;;207VM0101X 150 ;;207VX0000X 151 ;;207VX0201X 152 ;;207W00000X 153 ;;207X00000X 154 ;;207XS0106X 155 ;;207XS0114X 156 ;;207XS0117X 157 ;;207XX0004X 158 ;;207XX0005X 159 ;;207XX0801X 160 ;;207Y00000X 161 ;;207YP0228X 162 ;;207YS0123X 163 ;;207YX0007X 164 ;;207YX0602X 165 ;;207YX0901X 166 ;;207YX0905X 167 ;;207ZB0001X 168 ;;207ZC0500X 169 ;;207ZD0900X 170 ;;207ZF0201X 171 ;;207ZH0000X 172 ;;207ZI0100X 173 ;;207ZM0300X 174 ;;207ZN0500X 175 ;;207ZP0007X 176 ;;207ZP0101X 177 ;;207ZP0102X 178 ;;207ZP0104X 179 ;;207ZP0105X 180 ;;207ZP0213X 181 ;;208000000X 182 ;;2080A0000X 183 ;;2080I0007X 184 ;;2080N0001X 185 ;;2080P0006X 186 ;;2080P0008X 187 ;;2080P0201X 188 ;;2080P0202X 189 ;;2080P0203X 190 ;;2080P0204X 191 ;;2080P0205X 192 ;;2080P0206X 193 ;;2080P0207X 194 ;;2080P0208X 195 ;;2080P0210X 196 ;;2080P0214X 197 ;;2080P0216X 198 ;;2080S0010X 199 ;;2080T0002X 200 ;;208100000X 201 ;;2081P0004X 202 ;;2081P0010X 203 ;;2081P2900X 204 ;;2081S0010X 205 ;;208200000X 206 ;;2082S0099X 207 ;;2082S0105X 208 ;;2083A0100X 209 ;;2083P0011X 210 ;;2083P0500X 211 ;;2083P0901X 212 ;;2083S0010X 213 ;;2083T0002X 214 ;;2083X0100X 215 ;;2084A0401X 216 ;;2084F0202X 217 ;;2084N0400X 218 ;;2084N0402X 219 ;;2084N0600X 220 ;;2084P0005X 221 ;;2084P0800X 222 ;;2084P0802X 223 ;;2084P0804X 224 ;;2084P0805X 225 ;;2084P2900X 226 ;;2084S0010X 227 ;;2084V0102X 228 ;;2085B0100X 229 ;;2085N0700X 230 ;;2085N0904X 231 ;;2085P0229X 232 ;;2085R0001X 233 ;;2085R0202X 234 ;;2085R0203X 235 ;;2085R0204X 236 ;;2085R0205X 237 ;;2085U0001X 238 ;;208600000X 239 ;;2086S0102X 240 ;;2086S0105X 241 ;;2086S0120X 242 ;;2086S0122X 243 ;;2086S0127X 244 ;;2086S0129X 245 ;;2086X0206X 246 ;;208800000X 247 ;;208C00000X 248 ;;208D00000X 249 ;;208G00000X 250 ;;208M00000X 251 ;;208U00000X 252 ;;208VP0000X 253 ;;208VP0014X 254 ;;209800000X 255 ;;213E00000X 256 ;;213EG0000X 257 ;;213EP0504X 258 ;;213EP1101X 259 ;;213ER0200X 260 ;;213ES0000X 261 ;;213ES0103X 262 ;;213ES0131X 263 ;;225100000X 264 ;;2251C2600X 265 ;;2251E1200X 266 ;;2251E1300X 267 ;;2251G0304X 268 ;;2251H1200X 269 ;;2251H1300X 270 ;;2251N0400X 271 ;;2251P0200X 272 ;;2251S0007X 273 ;;2251X0800X 274 ;;225X00000X 275 ;;225XE1200X 276 ;;225XH1200X 277 ;;225XH1300X 278 ;;225XN1300X 279 ;;225XP0200X 280 ;;225XR0403X 281 ;;231H00000X 282 ;;231HA2400X 283 ;;231HA2500X 284 ;;237600000X 285 ;;363A00000X 286 ;;363AM0700X 287 ;;363AS0400X 288 ;;363L00000X 289 ;;363LA2100X 290 ;;363LA2200X 291 ;;363LC0200X 292 ;;363LC1500X 293 ;;363LF0000X 294 ;;363LG0600X 295 ;;363LN0000X 296 ;;363LN0005X 297 ;;363LP0200X 298 ;;363LP0222X 299 ;;363LP0808X 300 ;;363LP1700X 301 ;;363LP2300X 302 ;;363LS0200X 303 ;;363LW0102X 304 ;;363LX0001X 305 ;;363LX0106X 306 ;;364S00000X 307 ;;364SA2100X 308 ;;364SA2200X 309 ;;364SC0200X 310 ;;364SC1501X 311 ;;364SC2300X 312 ;;364SE0003X 313 ;;364SE1400X 314 ;;364SF0001X 315 ;;364SG0600X 316 ;;364SH0200X 317 ;;364SH1100X 318 ;;364SI0800X 319 ;;364SL0600X 320 ;;364SM0705X 321 ;;364SN0000X 322 ;;364SN0800X 323 ;;364SP0200X 324 ;;364SP0807X 325 ;;364SP0808X 326 ;;364SP0809X 327 ;;364SP0810X 328 ;;364SP0811X 329 ;;364SP0812X 330 ;;364SP0813X 331 ;;364SP1700X 332 ;;364SP2800X 333 ;;364SR0400X 334 ;;364SS0200X 335 ;;364ST0500X 336 ;;364SW0102X 337 ;;364SX0106X 338 ;;364SX0200X 339 ;;364SX0204X 340 ;;367500000X 341 ;;367A00000X 342 ;;367H00000X 343 ;; -
WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPIE1.m
r613 r623 1 XUSNPIE1 ;FO-OAKLAND/JLI - NATIONAL PROVIDER IDENTIFIER DATA CAPTURE ;5/13/08 17:32 2 ;;8.0;KERNEL;**420,410,435,454,462,480**; July 10, 1995;Build 38 3 ;;Per VHA Directive 2004-038, this routine should not be modified 4 Q 5 ; 6 SET(XUSIEN,XUSNPI) ; 7 ; set value for NPI related fields (#41.97-41.99) in file #200 8 N XUSFDA,XUSIENS,X 9 S X=$G(^VA(200,XUSIEN,"NPI")) 10 S XUSIENS=XUSIEN_"," 11 S XUSFDA(200,XUSIENS,41.99)=XUSNPI 12 S XUSFDA(200,XUSIENS,41.98)="D" 13 S XUSFDA(200,XUSIENS,41.97)=1 14 D FILE^DIE("","XUSFDA") 15 Q 16 ; 17 SET1(XUSIEN,XUSNPI) ; 18 ; set value for NPI field (#41.99) in file #4 19 N OLDNPI S OLDNPI=$P($G(^DIC(4,XUSIEN,"NPI")),"^") 20 I OLDNPI K ^DIC(4,"ANPI",OLDNPI,XUSIEN) 21 S ^DIC(4,XUSIEN,"NPI")=XUSNPI,^DIC(4,"ANPI",XUSNPI,XUSIEN)="" 22 Q 23 ; 24 SIGNON ; .ACT - run at user sign-on display message if NEEDS AN NPI 25 N XVAL,DATETIME,OPT,XVALTIME 26 I $$CHEKNPI^XUSNPIED(DUZ) W !!,"To enter your NPI value enter NPI at a menu prompt to jump to the",!,"edit option.",! H 1 27 ; following to insure CBO List is scheduled to run on first day of month 28 S XVALTIME=$E(DT,6,7) I '((XVALTIME="01")!(XVALTIME="15")) Q 29 S XVAL=+$E($$NOW^XLFDT(),6,10) I XVAL>(XVALTIME_".19"),XVAL<(XVALTIME_".1958") D ; 7 PM TO 7:58 PM ON 1ST OF MONTH 30 . S OPT=$$FIND1^DIC(19.2,"","","XUS NPI CBO LIST") I OPT'>0 L +^TMP("XUS NPI CBO LOCK"):0 Q:'$T D CBOQUEUE L -^TMP("XUS NPI CBO LOCK") Q 31 . S DATETIME=$$GET1^DIQ(19.2,OPT_",",2) 32 . I DATETIME'=$$FMTE^XLFDT(DT_".2") L +^DIC(19.2,OPT):0 Q:'$T D SETQUEUE(OPT,DT_".2") L -^DIC(19.2,OPT) Q 33 . I '$$GET1^DIQ(19.2,OPT_",",99.1) L +^DIC(19.2,OPT):0 Q:'$T D L -^DIC(19.2,OPT) 34 . . D SETQUEUE(OPT,"@") 35 . . D SETQUEUE(OPT,DT_".2") 36 . . Q 37 . Q 38 Q 39 ; 40 SETQUEUE(OPT,VALUE) ; 41 N FDA S FDA(19.2,OPT_",",2)=VALUE D FILE^DIE("","FDA") 42 Q 43 ; 44 POSTINIT ; 45 N XUGLOB,XUUSER,XIEN,X,ZTDESC,ZTDTH,ZTIO,ZTRTN 46 ;S XIEN=$$FIND1^DIC(19,"","","XUCOMMAND") I XIEN>0,$$FIND1^DIC(19.01,","_XIEN_",","","XUS NPI PROVIDER SELF ENTRY")'>0 S X=$$ADD^XPDMENU("XUCOMMAND","XUS NPI PROVIDER SELF ENTRY","NPI","") 47 ;S XIEN=$$FIND1^DIC(19,"","","XU USER SIGN-ON") I XIEN>0,$$FIND1^DIC(19.01,","_XIEN_",","","XUS NPI SIGNON CHECK")'>0 S X=$$ADD^XPDMENU("XU USER SIGN-ON","XUS NPI SIGNON CHECK","","") 48 ; get global containing Taxonomy values 49 S XUGLOB=$$CHKGLOB^XUSNPIED() 50 ; go through file 200 and ma 51 S XUUSER=0 F S XUUSER=$O(^VA(200,XUUSER)) Q:XUUSER'>0 I $$ACTIVE^XUSER(XUUSER) D DOUSER^XUSNPIED(XUUSER,XUGLOB) 52 ; and send CBO a starting point list 53 ;S ZTIO="",ZTDTH=$$NOW^XLFDT(),ZTRTN="CBOLIST^XUSNPIED",ZTDESC="XUS NPI CBOLIST MESSAGE GENERATION" D ^%ZTLOAD 54 ; set up to generate CBO list monthly 55 D CBOQUEUE 56 Q 57 ; 58 CBOQUEUE ; 59 N FDA,XUSVAL 60 ; check for already queued 61 S XUSVAL=$$FIND1^DIC(19.2,"","","XUS NPI CBO LIST") I XUSVAL>0 D Q 62 . S FDA(19.2,XUSVAL_",",2)=$$SETDATE() 63 . S FDA(19.2,XUSVAL_",",6)="1M(1@2000,15@2000)" 64 . N ZTQUEUED S ZTQUEUED=1 D FILE^DIE("","FDA") K ZTQUEUED 65 . Q 66 ; no set up queued job 67 S XUSVAL=$$FIND1^DIC(19,"","","XUS NPI CBO LIST") Q:XUSVAL'>0 S FDA(19.2,"+1,",.01)=XUSVAL 68 S FDA(19.2,"+1,",2)=$$SETDATE() 69 S FDA(19.2,"+1,",6)="1M(1@2000,15@2000)" 70 N ZTQUEUED S ZTQUEUED=1 D UPDATE^DIE("","FDA") K ZTQUEUED 71 Q 72 ; 73 SETDATE() ; 74 Q $S($E($$NOW^XLFDT(),6,10)<1.2:DT,$E($$NOW^XLFDT(),6,10)<15.2:$E(DT,1,5)_"15",$E(DT,4,5)>11:(($E(DT,1,3)+1)_"0101"),1:($E(DT,1,5)+1)_"01")_".2" 75 ; 76 CHKOLD1(IEN) ; 77 D CHKOLD1^XUSNPIE2(IEN) 78 Q 79 ; 80 CLERXMPT ; 81 D CLERXMPT^XUSNPIE2 82 Q 83 ; 84 CHKDGT(XUSNPI,XUSDA,XUSQI) ; INPUT TRANSFORM 85 N XUS S XUS=$$CHKDGT^XUSNPI(XUSNPI) 86 I XUS'>0 Q 0 87 N XUSQIK S XUSQIK=$$QI^XUSNPI(XUSNPI) I XUSQIK=0 Q 1 88 ; Check whether NPI is already being used. If so, issue error or warning. 89 N NPIUSED,XUSRSLT 90 S NPIUSED=$$NPIUSED^XUSNPI1(XUSNPI,XUSQI,XUSQIK,XUSDA,.XUSRSLT,1) 91 ; If an error was encountered, quit 0. 92 I NPIUSED=1 Q 0 93 ; If a warning was encountered, quit 1 (Person on file 200 and 355.93 can share NPI) 94 I NPIUSED=2 Q 1 95 ; If current provider previously had this NPI, make sure the NPI being added is the most 96 ; current one in the EFFECTIVE DATE/TIME multiple (history). 97 N XUSROOT S XUSROOT=$$GET^XPAR("PKG.KERNEL","XUSNPI QUALIFIED IDENTIFIER",XUSQI) 98 I $E(XUSROOT)'="^" S XUSROOT="^"_XUSROOT 99 N XUS1 S XUS1=XUSROOT_XUSDA_","_"""NPISTATUS"""_","_"""A"""_")" 100 N XUS2 S XUS2=$O(@XUS1,-1) I XUS2'>0 Q 1 101 S XUS1=XUSROOT_XUSDA_","_"""NPISTATUS"""_","_XUS2_","_0_")" 102 S XUS2=$G(@XUS1) I $P(XUS2,"^",3)=XUSNPI Q 1 103 Q 0 1 XUSNPIE1 ;FO-OAKLAND/JLI - NATIONAL PROVIDER IDENTIFIER DATA CAPTURE ;05/02/07 2 ;;8.0;KERNEL;**420,410,435,454,462**; July 10, 1995;Build 3 3 ; 4 Q 5 ; 6 SET(XUSIEN,XUSNPI) ; 7 ; set value for NPI field (#41.99) in file #200 8 N OLDNPI S OLDNPI=$P($G(^VA(200,XUSIEN,"NPI")),"^") 9 I OLDNPI K ^VA(200,"ANPI",OLDNPI,XUSIEN) 10 S ^VA(200,XUSIEN,"NPI")=XUSNPI_U_"D",^VA(200,"ANPI",XUSNPI,XUSIEN)="" 11 Q 12 ; 13 SET1(XUSIEN,XUSNPI) ; 14 ; set value for NPI field (#41.99) in file #4 15 N OLDNPI S OLDNPI=$P($G(^DIC(4,XUSIEN,"NPI")),"^") 16 I OLDNPI K ^DIC(4,"ANPI",OLDNPI,XUSIEN) 17 S ^DIC(4,XUSIEN,"NPI")=XUSNPI,^DIC(4,"ANPI",XUSNPI,XUSIEN)="" 18 Q 19 ; 20 SIGNON ; .ACT - run at user sign-on display message if NEEDS AN NPI 21 N XVAL,DATETIME,OPT,XVALTIME 22 I $$CHEKNPI^XUSNPIED(DUZ) W !!,"To enter your NPI value enter NPI at a menu prompt to jump to the",!,"edit option.",! H 1 23 ; following to insure CBO List is scheduled to run on first day of month 24 S XVALTIME=$E(DT,6,7) I '((XVALTIME="01")!(XVALTIME="15")) Q 25 S XVAL=+$E($$NOW^XLFDT(),6,10) I XVAL>(XVALTIME_".19"),XVAL<(XVALTIME_".1958") D ; 7 PM TO 7:58 PM ON 1ST OF MONTH 26 . S OPT=$$FIND1^DIC(19.2,"","","XUS NPI CBO LIST") I OPT'>0 L +^TMP("XUS NPI CBO LOCK"):0 Q:'$T D CBOQUEUE L -^TMP("XUS NPI CBO LOCK") Q 27 . S DATETIME=$$GET1^DIQ(19.2,OPT_",",2) 28 . I DATETIME'=$$FMTE^XLFDT(DT_".2") L +^DIC(19.2,OPT):0 Q:'$T D SETQUEUE(OPT,DT_".2") L -^DIC(19.2,OPT) Q 29 . I '$$GET1^DIQ(19.2,OPT_",",99.1) L +^DIC(19.2,OPT):0 Q:'$T D L -^DIC(19.2,OPT) 30 . . D SETQUEUE(OPT,"@") 31 . . D SETQUEUE(OPT,DT_".2") 32 . . Q 33 . Q 34 Q 35 ; 36 SETQUEUE(OPT,VALUE) ; 37 N FDA S FDA(19.2,OPT_",",2)=VALUE D FILE^DIE("","FDA") 38 Q 39 ; 40 POSTINIT ; 41 N XUGLOB,XUUSER,XIEN,X,ZTDESC,ZTDTH,ZTIO,ZTRTN 42 ;S XIEN=$$FIND1^DIC(19,"","","XUCOMMAND") I XIEN>0,$$FIND1^DIC(19.01,","_XIEN_",","","XUS NPI PROVIDER SELF ENTRY")'>0 S X=$$ADD^XPDMENU("XUCOMMAND","XUS NPI PROVIDER SELF ENTRY","NPI","") 43 ;S XIEN=$$FIND1^DIC(19,"","","XU USER SIGN-ON") I XIEN>0,$$FIND1^DIC(19.01,","_XIEN_",","","XUS NPI SIGNON CHECK")'>0 S X=$$ADD^XPDMENU("XU USER SIGN-ON","XUS NPI SIGNON CHECK","","") 44 ; get global containing Taxonomy values 45 S XUGLOB=$$CHKGLOB^XUSNPIED() 46 ; go through file 200 and ma 47 S XUUSER=0 F S XUUSER=$O(^VA(200,XUUSER)) Q:XUUSER'>0 I $$ACTIVE^XUSER(XUUSER) D DOUSER^XUSNPIED(XUUSER,XUGLOB) 48 ; and send CBO a starting point list 49 ;S ZTIO="",ZTDTH=$$NOW^XLFDT(),ZTRTN="CBOLIST^XUSNPIED",ZTDESC="XUS NPI CBOLIST MESSAGE GENERATION" D ^%ZTLOAD 50 ; set up to generate CBO list monthly 51 D CBOQUEUE 52 Q 53 ; 54 CBOQUEUE ; 55 N FDA,XUSVAL 56 ; check for already queued 57 S XUSVAL=$$FIND1^DIC(19.2,"","","XUS NPI CBO LIST") I XUSVAL>0 D Q 58 . S FDA(19.2,XUSVAL_",",2)=$$SETDATE() 59 . S FDA(19.2,XUSVAL_",",6)="1M(1@2000,15@2000)" 60 . N ZTQUEUED S ZTQUEUED=1 D FILE^DIE("","FDA") K ZTQUEUED 61 . Q 62 ; no set up queued job 63 S XUSVAL=$$FIND1^DIC(19,"","","XUS NPI CBO LIST") Q:XUSVAL'>0 S FDA(19.2,"+1,",.01)=XUSVAL 64 S FDA(19.2,"+1,",2)=$$SETDATE() 65 S FDA(19.2,"+1,",6)="1M(1@2000,15@2000)" 66 N ZTQUEUED S ZTQUEUED=1 D UPDATE^DIE("","FDA") K ZTQUEUED 67 Q 68 ; 69 SETDATE() ; 70 Q $S($E($$NOW^XLFDT(),6,10)<1.2:DT,$E($$NOW^XLFDT(),6,10)<15.2:$E(DT,1,5)_"15",$E(DT,4,5)>11:(($E(DT,1,3)+1)_"0101"),1:($E(DT,1,5)+1)_"01")_".2" 71 ; 72 EDITNPI(IEN) ; main entry of NPI value 73 ; IEN is the internal entry number in file 200 for the provider 74 ; 75 N DATEVAL,DESCRIP,DONE,NPIVAL1,NPIVAL2,PROVNAME,XX,Y,CURRNPI 76 N ODATEVAL,OIEN,OLDNPI,XUSNONED,DIR,ADDNPI,DELETNPI,NOOLDNPI,XUSQI 77 S ADDNPI=1,DELETNPI=2,NOOLDNPI=0 78 S PROVNAME=$$GET1^DIQ(200,IEN_",",.01) 79 ;I $$ACTIVE^XUSER(IEN) W !,"This user isn't currently active" Q 80 I $$GETTAXON^XUSNPIED(IEN,.DESCRIP)=-1 W !,"This user doesn't have a Taxonomy Code indicating a need for an NPI." S XUSNONED=1 ; but don't quit on that 81 I $$NPISTATS^XUSNPIED(IEN)="D" S XUSNONED=1 82 I $$NPISTATS^XUSNPIED(IEN)="E" W !,"This provider has been indicated as being EXEMPT from needing an NPI value.",!," Use Exempt option to remove it first" Q 83 S OLDNPI=NOOLDNPI I $$NPISTATS^XUSNPIED(IEN)="D" D Q:OLDNPI=NOOLDNPI ; exit without changing 84 . N I,X,DIR 85 . S CURRNPI=$$GET1^DIQ(200,IEN_",",41.99) I CURRNPI="" Q 86 . S OIEN=$$SRCHNPI^XUSNPI("^VA(200,",IEN,CURRNPI) I OIEN>0 S ODATEVAL=$P(OIEN,U,2),OIEN=$O(^VA(200,IEN,"NPISTATUS","C",CURRNPI,"A"),-1) 87 . I '$D(ODATEVAL) S OLDNPI=2 ; can't find entry in multiple, delete entry at top 88 . W !,"This provider already has an NPI value (",CURRNPI,") entered." 89 . ;S DIR(0)="Y",DIR("A")="Do you want to ADD a new NPI value as the active one",DIR("B")="NO" D ^DIR S OLDNPI=Y Q:OLDNPI 90 . ;K DIR S DIR(0)="Y",DIR("A")="Do you REALLY want to **DELETE** this NPI value",DIR("B")="NO" D ^DIR I Y S OLDNPI=2 91 . S DIR(0)="S^D:Delete;R:Replace",DIR("A")="Do you want to (D)elete or (R)eplace this NPI value?",DIR("?")="Enter either D or R or ^ to quit with out editing" 92 . S DIR("?",1)="If the value was entered for the incorrect individual, it should be Deleted.",DIR("?",2)="Otherwise it should be Replaced" 93 . D ^DIR K DIR Q:"DR"'[Y I Y="R" S OLDNPI=ADDNPI Q 94 . S DIR(0)="S^V:VALID;E:ERROR",DIR("A",1)="Was the original NPI (V)alid for this provider",DIR("A")="or was it entered in (E)rror?",DIR("?")="Enter either V or E or ^ to quit with out editing" 95 . S DIR("?",1)="If the NPI value was entered for the incorrect individual, respond E,",DIR("?",2)="otherwise enter V" 96 . D ^DIR K DIR Q:"EV"'[Y I Y="V" S Y=$$ADDNPI^XUSNPI("Individual_ID",IEN,CURRNPI,$$NOW^XLFDT(),0) D S OLDNPI=NOOLDNPI Q 97 . . W !,$S(Y>-1:"Entry has been marked inactive.",1:$P(Y,U,2)),! Q:+Y=-1 98 . . N XUFDA S XUFDA(200,IEN_",",41.98)="@",XUFDA(200,IEN_",",41.99)="@" D FILE^DIE("","XUFDA") S Y=$$CHEKNPI^XUSNPIED(IEN) 99 . . Q 100 . S OLDNPI=DELETNPI 101 . Q 102 I $$CHEKNPI^XUSNPIED(IEN)=0,OLDNPI=0 W !,"Need for an NPI value isn't indicated - but you can enter an NPI",$C(7) 103 I IEN'=DUZ W !,"Provider: ",PROVNAME," ","XXX-XX-"_$E($$GET1^DIQ(200,IEN_",",9),6,9)," DOB: " S XX=$P($G(^VA(200,IEN,1)),U,3) S:XX'="" XX=$$DATE10^XUSNPIED(XX) W XX 104 ;I IEN'=DUZ W !,"Status: Active" 105 S DONE=0 I OLDNPI'=DELETNPI F R !,"Enter NPI (10 digits): ",NPIVAL1:DTIME Q:'$T Q:NPIVAL1="" Q:NPIVAL1=U D Q:DONE 106 . I NPIVAL1'?10N D Q 107 . . W !,$C(7),"Enter a 10 digit National Provider Identifier which is obtained ",!,"from 'https://nppes.cms.hhs.gov/NPPES/Welcome.do'" 108 . . Q:$$PROD^XUPROD() W ! K DIR S DIR(0)="Y",DIR("A")="Do you want to generate a test NPI value" D ^DIR Q:'Y 109 . . R !,"Enter a nine (9) digit number as the base: ",Y:DTIME Q:Y'?9N 110 . . W !,"The complete NPI value is: ",Y_$$CKDIGIT^XUSNPI(Y),! 111 . . Q 112 . S XUSQI=$$QI^XUSNPI(NPIVAL1) I +XUSQI=0,$P(XUSQI,U,2)="Invalid NPI" W !,"NPI values have a specific structure to validate them...",!,"The Checksum for this entry is not valid",! Q 113 . I XUSQI'=0 N ZZ,DONE1 S DONE1=0 D GETLST^XPAR(.ZZ,"PKG.KERNEL","XUSNPI QUALIFIED IDENTIFIER") D Q:DONE1 114 . . S ZZ="" F S ZZ=$O(ZZ(ZZ)) Q:ZZ'>0 I $P(ZZ(ZZ),U)=$P(XUSQI,U) W !,"That NPI value is already associated with "_$P(@("^"_$P(ZZ(ZZ),U,2)_$P(XUSQI,U,2)_",0)"),U) S DONE1=1 Q 115 . . Q 116 . R !,"Please re-enter NPI : ",NPIVAL2:DTIME Q:'$T I NPIVAL1'=NPIVAL2 W !,"Values do not match!" Q 117 . S DONE=1 118 . Q 119 I OLDNPI=DELETNPI D 120 . I $D(ODATEVAL) D S Y=$$CHEKNPI^XUSNPIED(IEN) Q 121 . . N DIR S DIR(0)="Y",DIR("A")="Confirm that you want to **DELETE** this incorrectly entered NPI",DIR("B")="NO" D ^DIR Q:'Y 122 . . D DELETNPI^XUSNPIE2(IEN,OIEN,ODATEVAL) 123 . . D CHKOLD1(IEN) ; check for earlier value, and activate if present 124 . . W !,"Entry was DELETED..." 125 . . Q 126 . D DELETNPI^XUSNPIE2(IEN) ; clean up where no entry in multiple 127 . W !,"Entry was DELETED..." 128 . Q 129 I 'DONE Q 130 ;N DIR S DIR("A")="Enter the date the provider was issued this number from CMS: ",DIR(0)="D^:"_$$NOW^XLFDT() D ^DIR Q:Y'>0 S DATEVAL=+Y 131 S DATEVAL=$$NOW^XLFDT() 132 ; mark previous NPI value as inactive 133 I OLDNPI=ADDNPI S DONE=$$ADDNPI^XUSNPI("Individual_ID",IEN,CURRNPI,DATEVAL,0) ; set status to INACTIVE 134 S DONE=$$ADDNPI^XUSNPI("Individual_ID",IEN,NPIVAL1,DATEVAL) I +DONE=-1 W !,"Problem writing that value into the database! -- It was **NOT** recorded.",!,$P(DONE,U,2) Q 135 W !!,"For provider ",PROVNAME," "_$S('$D(XUSNONED):"(who requires an NPI), ",1:"")_"the NPI ",NPIVAL1,!,"was saved to VistA successfully." 136 Q 137 ; 138 CHKOLD1(IEN) ; 139 D CHKOLD1^XUSNPIE2(IEN) 140 Q 141 ; 142 CLERXMPT ; 143 D CLERXMPT^XUSNPIE2 144 Q 145 ; 146 CHKDGT(XUSNPI,XUSDA,XUSQI) ; INPUT TRANSFORM 147 N XUS S XUS=$$CHKDGT^XUSNPI(XUSNPI) 148 I XUS'>0 Q 0 149 N XUSQIK S XUSQIK=$$QI^XUSNPI(XUSNPI) I XUSQIK=0 Q 1 150 I XUSQIK'=0,$P(XUSQIK,"^",2)'=XUSDA Q 0 ; return zero if the NPI found and not bellong to the current user 151 N XUSQIK1 S XUSQIK1=$P(XUSQIK,"^") 152 I XUSQI'=XUSQIK1 Q 0 153 I $P($P(XUSQIK,"^",4),";")="Inactive" Q 0 154 N XUSROOT S XUSROOT=$$GET^XPAR("PKG.KERNEL","XUSNPI QUALIFIED IDENTIFIER",XUSQIK1) 155 I $E(XUSROOT)'="^" S XUSROOT="^"_XUSROOT 156 N XUS1 S XUS1=XUSROOT_XUSDA_","_"""NPISTATUS"""_","_"""A"""_")" 157 N XUS2 S XUS2=$O(@XUS1,-1) I XUS2'>0 Q 1 158 S XUS1=XUSROOT_XUSDA_","_"""NPISTATUS"""_","_XUS2_","_0_")" 159 S XUS2=$G(@XUS1) I $P(XUS2,"^",3)=XUSNPI Q 1 160 Q 0 -
WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPIE2.m
r613 r623 1 XUSNPIE2 ;FO-OAKLAND/JLI - DATA ENTRY FOR INITIAL NPI VALUES ;5/13/08 17:41 2 ;;8.0;KERNEL;**410,435,454,462,480**;Jul 10, 1995;Build 38 3 ;;Per VHA Directive 2004-038, this routine should not be modified 4 Q 5 ; 6 PRINTOPT ; 7 N DIR,%ZIS,ION,OPTION,PRNTFRMT,XUSDIV,XUSSORT,XUSRESO,Y,ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTSK 8 K IO("Q") 9 W !,"Select one of the following:",!!,?11,"1",?21,"All providers",!,?11,"2",?21,"All providers without NPI numbers",! 10 S DIR(0)="N^1:2",DIR("A")="Select a report option",DIR("B")="1" D ^DIR K DIR Q:Y'>0 S OPTION=+Y 11 S XUSRESO="" D Q:XUSRESO="" 12 . S DIR(0)="S^P:Providers who are not residents;R:Residents only;B:Both" 13 . S DIR("B")="P",DIR("A")="Selection: " 14 . D ^DIR K DIR Q:"PRB"'[Y 15 . S XUSRESO=Y Q 16 S DIR(0)="Y",DIR("B")="NO",DIR("A")="Sort by DIVISION" D ^DIR K DIR Q:Y="^" S XUSDIV=+Y 17 S PRNTFRMT=1 18 I XUSDIV S DIR(0)="N^1:2",DIR("A")="Output type (1=Printed text or 2=^-delimited)" D ^DIR K DIR Q:Y'>0 S PRNTFRMT=Y 19 S DIR(0)="Y",DIR("B")="YES",DIR("A")="Sort by SERVICE/SECTION"_$S(XUSDIV>0:" (as well)",1:"") D ^DIR K DIR Q:Y="^" S XUSSORT=+Y 20 W !!,">>> Report processing time is approximately 10 minutes." 21 W !," Recommend text output be queued to a network printer." 22 W ! 23 S %ZIS="MQ" D ^%ZIS Q:POP 24 I $D(IO("Q")) D Q 25 . S ZTSAVE("OPTION")="",ZTSAVE("XUSSORT")="",ZTSAVE("XUSDIV")="",ZTSAVE("PRNTFRMT")="",ZTSAVE("XUSRESO")="" 26 . S ZTIO=ION,ZTRTN="DQ^XUSNPIE2",ZTDESC="NPI PRINT JOB FOR OPTION "_OPTION 27 . D ^%ZTLOAD W:$D(ZTSK) !,"Queued as Task "_ZTSK D HOME^%ZIS Q 28 ; 29 DQ ; entry point for queued print job 30 U IO D PRNTPROV(OPTION,XUSSORT,XUSDIV,PRNTFRMT,XUSRESO) 31 U IO D ^%ZISC 32 Q 33 ; 34 PRNTPROV(OPTION,XUSSORT,XUSDIV,PRNTFRMT,XUSRESO) ; 35 ; PRINT PROVIDER INFO 36 ; 37 ; OPTION SPECIFIES TYPE OF PRINT - 1=ALL PROVIDERS, 2=NEEDS NPI ONLY 38 ; XUSSORT INDICATES WHETHER SORTED BY SERVICE/SECTION 39 ; XUSDIV INDICATES WHETHER SORTED BY DIVISION 40 ; PRNTFRMT INDICATES TYPE OF OUTPUT, PRINTED OR ^-DELIMITED 41 ; 42 ; ZEXCEPT: IOSL - KERNEL VARIABLE 43 N PAGENUM,LINENUM,PROVNAME,TAXDESCR,TAXONOMY,SERVSECT,DIRUT,DTOUT 44 N GLOBLOC,IEN,NPI,DATETIME,GLOBVALU,NCOUNT,GLOBLOC1,XUSDIVNM,CNTTOTAL,CNTNONE,CNTEXMPT,CNTDONE,MULTDIV,MULTDIVC 45 S CNTTOTAL=0,CNTNONE=0,CNTEXMPT=0,CNTDONE=0 46 S PAGENUM=0,LINENUM=0 47 S DATETIME=$$NOW^XLFDT() 48 S GLOBLOC1=$$GETDATA(OPTION,XUSSORT,XUSDIV,XUSRESO) 49 I PRNTFRMT'=1 W !,"PROVIDER_NAME^LAST4^IEN^NPI^TAXONOMY_CODE^TAXONOMY DESCRIPTION"_$S(XUSDIV:"^DIVISION",1:"")_$S(XUSSORT:"^SERVICE/SECTION",1:"") 50 S GLOBLOC=GLOBLOC1,XUSDIVNM="" F S XUSDIVNM=$O(@GLOBLOC1@(XUSDIVNM)) Q:XUSDIVNM="" D Q:$D(DIRUT)!$D(DTOUT) 51 . S SERVSECT="" F S SERVSECT=$O(@GLOBLOC1@(XUSDIVNM,SERVSECT)) Q:SERVSECT="" S GLOBLOC=$NA(@GLOBLOC1@(XUSDIVNM,SERVSECT)) D Q:$D(DIRUT)!$D(DTOUT) 52 . . I PRNTFRMT=1 D HEADER(OPTION,DATETIME,.PAGENUM,.LINENUM,XUSDIV,XUSDIVNM,XUSSORT,SERVSECT,XUSRESO) Q:$D(DIRUT)!$D(DTOUT) 53 . . S PROVNAME="" F S PROVNAME=$O(@GLOBLOC@(PROVNAME)) Q:PROVNAME="" Q:$D(DIRUT)!$D(DTOUT) S IEN=0 F S IEN=$O(@GLOBLOC@(PROVNAME,IEN)) Q:IEN'>0 D Q:$D(DIRUT)!$D(DTOUT) 54 . . . S NCOUNT=0 55 . . . S TAXDESCR="" F S TAXDESCR=$O(@GLOBLOC@(PROVNAME,IEN,TAXDESCR)) Q:TAXDESCR="" S GLOBVALU=@GLOBLOC@(PROVNAME,IEN,TAXDESCR) D 56 . . . . S NPI=$P(GLOBVALU,U,3),TAXONOMY=$P(GLOBVALU,U,4) 57 . . . . I PRNTFRMT=1 S NCOUNT=NCOUNT+1 W:NCOUNT=1 !,PROVNAME,?33,$$ALIGNRGT(IEN,11),?49,NPI W !,?6,TAXONOMY," ",TAXDESCR 58 . . . . I PRNTFRMT'=1 W !,PROVNAME_U_$E($$GET1^DIQ(200,IEN_",",9),6,9)_U_IEN_U_NPI_U_TAXONOMY_U_TAXDESCR_$S(XUSDIV:U_XUSDIVNM,1:"")_$S(XUSSORT:U_SERVSECT,1:"") 59 . . . . Q 60 . . . I PRNTFRMT=1 S LINENUM=LINENUM+NCOUNT+1 I LINENUM>(IOSL-4) D HEADER(OPTION,DATETIME,.PAGENUM,.LINENUM,XUSDIV,XUSDIVNM,XUSSORT,SERVSECT,XUSRESO) Q:$D(DIRUT)!$D(DTOUT) 61 . . . Q 62 . . Q 63 . Q 64 I '($D(DIRUT)!$D(DTOUT)),PRNTFRMT=1 D 65 . S PROVNAME="" I $O(@GLOBLOC@(PROVNAME))="" W !,?20,"* * * N O D A T A F O U N D * * *",!! I 1 66 . E D 67 . . N TOTTYP S TOTTYP=$S(XUSRESO="R":"Residents",1:"Billable Providers") 68 . . W !!,"Total "_TOTTYP_":",?43,CNTTOTAL,!,TOTTYP_" with an NPI:",?43,CNTDONE,!,"EXEMPT "_TOTTYP_":",?43,CNTEXMPT,!,TOTTYP_" Still Needing an NPI:",?43,CNTNONE 69 . . I $G(MULTDIV)>0 W !!,MULTDIV," Providers were repeated a total of ",MULTDIVC," times",!," due to listing under multiple divisions" 70 . . Q 71 . W !!,?27,"*** End of Report ***" 72 . Q 73 Q 74 ; 75 HEADER(OPTION,DATETIME,PAGNOREF,LINNOREF,XUSDIV,XUSDIVNM,XUSSORT,SERVSECT,XUSRESO) ; 76 ; ZEXCEPT: IOF,IOST KERNEL IO VARIABLES 77 ; ZEXCEPT: DIRUT,DTOUT NEWED IN CALLING PRNTPROV - INDICATE QUIT TO PRNTPROV 78 N TEMPVAL,DIR,X,Y 79 S PAGNOREF=PAGNOREF+1 80 ; Don't page feed on the first page 81 IF PAGNOREF>1 I $E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR I 'Y S DIRUT=1 Q 82 IF PAGNOREF>1 W @IOF 83 W:$E(IOST,1,2)'="C-" ! 84 W "Active Provider Report ("_$S(XUSRESO="P":"no residents)",XUSRESO="R":"residents only)",1:"includes residents)") 85 W ?48,$$FMTE^XLFDT(DATETIME)," Page: ",PAGNOREF 86 W !," Report Option: Provider List Active Providers",$S(OPTION=2:" Without NPI Numbers",1:"") 87 W !!,"Provider Name",?39,"IEN",?49,$S(OPTION'=2:"NPI",1:"") 88 W !," Taxonomy" 89 W !,"--------------------------------------------------------------------------------" 90 S LINNOREF=6 91 I XUSDIV W !,"DIVISION: ",XUSDIVNM," " S LINNOREF=LINNOREF+1 92 I XUSSORT W:'XUSDIV ! W "SERVICE/SECTION: ",SERVSECT S:'XUSDIV LINNOREF=LINNOREF+1 93 Q 94 ; 95 GETDATA(OPTION,XUSSORT,XUSDIV,XUSRESO) ; get data for reports for providers 96 N NPI,PROVNAME,TAXDESCR,TAXONOMY,XUSDEFLT,XUSDIVCN,XUSDIVN,XUSDIVNM,XUSGLOB,XUSACTV,XUSSKIP 97 N XUSIEN,XUSSERVC,XUSVAL,CNTCLEAN,X 98 S XUSRESO=$G(XUSRESO) 99 ; ZEXCEPT: CNTTOTAL,CNTNONE,CNTEXMPT,CNTDONE - NEWed and initialized in PRNTPROV or killed based on CNTCLEAN 100 S CNTCLEAN=0 I '$D(CNTTOTAL) S CNTCLEAN=1 101 S XUSGLOB=$NA(^TMP($J,"XUSNPIPRNT")) K @XUSGLOB 102 I 'XUSDIV S XUSDIVNM(1)=" ",XUSDEFLT=" " 103 I XUSDIV S XUSDEFLT=$$NS^XUAF4($$KSP^XUPARAM("INST")),XUSDEFLT=$P(XUSDEFLT,U) 104 I 'XUSSORT S XUSSERVC=" " 105 F XUSIEN=0:0 S XUSIEN=$O(^VA(200,XUSIEN)) Q:XUSIEN'>0 D 106 . ; Don't report TERMINATED or DISUSERed users 107 . S XUSACTV=$$ACTIVE^XUSER(XUSIEN) 108 . I XUSACTV=""!($P(XUSACTV,U)=0) Q 109 . ; Don't report users with null NPI ENTRY STATUS 110 . S XUSVAL=$$CHEKNPI^XUSNPIED(XUSIEN),XUSVAL=$$NPISTATS^XUSNPIED(XUSIEN) 111 . Q:XUSVAL="" 112 . S PROVNAME=$$GET1^DIQ(200,XUSIEN_",",.01),NPI=$$GETNPI^XUSNPIED(XUSIEN),TAXONOMY=$$GETTAXON^XUSNPIED(XUSIEN,.TAXDESCR) I TAXONOMY=-1 S TAXONOMY=" ",TAXDESCR=" " 113 . ; Determine whether provider is a resident for local reports. 114 . I OPTION'=3,XUSRESO'="B" S XUSSKIP=0 D Q:XUSSKIP 115 . . I XUSRESO="R",TAXONOMY'="390200000X" S XUSSKIP=1 Q 116 . . I XUSRESO="P",TAXONOMY="390200000X" S XUSSKIP=1 117 . . Q 118 . I NPI="",$$EXMPTNPI^XUSNPIED(XUSIEN) S NPI="EXEMPTED " 119 . S CNTTOTAL=$G(CNTTOTAL)+1 S:NPI="" CNTNONE=$G(CNTNONE)+1 S:NPI="EXEMPTED " CNTEXMPT=$G(CNTEXMPT)+1 S:NPI?10N CNTDONE=$G(CNTDONE)+1 120 . I '((XUSVAL="N")!(OPTION'=2)) Q 121 . I XUSSORT S XUSSERVC=$$GET1^DIQ(200,XUSIEN_",",29) I XUSSERVC="" S XUSSERVC=" " 122 . I XUSDIV D 123 . . K XUSDIVNM S XUSDIVCN=0,XUSDIVNM(1)=XUSDEFLT 124 . . F XUSDIVN=0:0 S XUSDIVN=$O(^VA(200,XUSIEN,2,XUSDIVN)) Q:XUSDIVN'>0 S XUSDIVCN=XUSDIVCN+1,XUSDIVNM(XUSDIVCN)=$$GET1^DIQ(200.02,XUSDIVN_","_XUSIEN_",",.01) 125 . . I XUSDIVCN>1 S MULTDIV=$G(MULTDIV)+1,MULTDIVC=$G(MULTDIVC)+XUSDIVCN-1 126 . . Q 127 . F XUSDIVN=0:0 S XUSDIVN=$O(XUSDIVNM(XUSDIVN)) Q:XUSDIVN'>0 D 128 . . S X=PROVNAME_U_XUSIEN_U_NPI_U_TAXONOMY_U_TAXDESCR 129 . . S @XUSGLOB@(XUSDIVNM(XUSDIVN),XUSSERVC,PROVNAME,XUSIEN,TAXDESCR)=X 130 . . Q 131 . Q 132 I CNTCLEAN K CNTTOTAL,CNTNONE,CNTEXMPT,CNTDONE 133 Q XUSGLOB 134 ; 135 ALIGNRGT(TEXT,WIDTH) ; align text right in a specified width 136 N RESULT 137 S $P(RESULT," ",WIDTH)=" ",RESULT=RESULT_TEXT,RESULT=$E(RESULT,$L(RESULT)-WIDTH+1,$L(RESULT)) 138 Q RESULT 139 ; 140 CHKOLD1(IEN) ; check for earlier value, and activate if present 141 N IEN1,STATUS,NPI,DATE,XUFDA 142 S IEN1=$O(^VA(200,IEN,"NPISTATUS"," "),-1) I IEN1>0 D I STATUS=0 D CHKOLD1(IEN) 143 . S STATUS=^VA(200,IEN,"NPISTATUS",IEN1,0),NPI=$P(STATUS,U,3),DATE=$P(STATUS,U),STATUS=$P(STATUS,U,2) 144 . I STATUS=0 D DELETNPI(IEN,IEN1,DATE) Q ; entry making it INACTIVE - remove it 145 . I STATUS=1 D SET^XUSNPIE1(IEN,NPI) 146 . Q 147 Q 148 ; 149 DELETNPI(IEN,OIEN,ODATEVAL) ; 150 N XUFDA 151 I $D(ODATEVAL) S XUFDA(200.042,OIEN_","_IEN_",",.01)="@" D FILE^DIE("","XUFDA") 152 I $O(^VA(200,IEN,"NPISTATUS",0))>0 Q 153 N XUFDA 154 I $$GET1^DIQ(200,IEN_",",41.99) S XUFDA(200,IEN_",",41.99)="@" 155 I $$GET1^DIQ(200,IEN_",",41.98)'="" S XUFDA(200,IEN_",",41.98)="@" 156 I $D(XUFDA) D FILE^DIE("","XUFDA") 157 Q 158 ; 159 CLERXMPT ; edit entry indicating whether a provider is exempt from needing an NPI 160 N DIC,DIR,FDA,IEN,Y 161 W ! S DIC="^VA(200,",DIC(0)="AEQ" S DIC("A")="select Provider: " D ^DIC Q:Y'>0 S IEN=+Y 162 I $$HASNPI^XUSNPIED(IEN) W !,"This Provider already has an NPI value. Nothing to do." Q 163 I '$$CHEKNPI^XUSNPIED(IEN),'$$EXMPTNPI^XUSNPIED(IEN) W !,"This Provider does not appear to need an NPI or Exemption." Q 164 I $$EXMPTNPI^XUSNPIED(IEN) D Q ; currently marked as Exempt 165 . S DIR(0)="Y",DIR("A")="Provider is currently EXEMPT from needing an NPI, set to NEEDS an NPI (Y/N)" D ^DIR I 'Y Q 166 . S FDA(200,IEN_",",41.98)="N" D FILE^DIE("","FDA") 167 . W !,$S($$NEEDSNPI^XUSNPIED(IEN):"File updated",1:"Ecountered a problem updating file, status NOT set to NEEDS an NPI") 168 . Q 169 ; check to make sure provider should be exempt 170 S DIR(0)="Y",DIR("A")="Confirm that Provider should be Exempt from needing an NPI (Y/N)" D ^DIR I 'Y Q 171 ; and update file to show as exempt 172 S FDA(200,IEN_",",41.98)="E" D FILE^DIE("","FDA") 173 W !,$S($$EXMPTNPI^XUSNPIED(IEN):"File updated",1:"Ecountered a problem updating file, status NOT set to EXEMPT") 174 Q 1 XUSNPIE2 ;FO-OAKLAND/JLI - DATA ENTRY FOR INITIAL NPI VALUES ;06/06/07 2 ;;8.0;KERNEL;**410,435,454,462**;Jul 10, 1995;Build 3 3 Q 4 ; 5 PRINTOPT ; 6 N DIR,%ZIS,ION,OPTION,PRNTFRMT,XUSDIV,XUSSORT,Y,ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTSK 7 K IO("Q") 8 W !,"Select one of the following:",!!,?11,"1",?21,"All providers",!,?11,"2",?21,"All providers without NPI numbers",! 9 S DIR(0)="N^1:2",DIR("A")="Select a report option",DIR("B")="1" D ^DIR K DIR Q:Y'>0 S OPTION=+Y 10 S DIR(0)="Y",DIR("B")="NO",DIR("A")="Sort by DIVISION" D ^DIR K DIR Q:Y="^" S XUSDIV=+Y 11 S PRNTFRMT=1 12 I XUSDIV S DIR(0)="N^1:2",DIR("A")="Output type (1=Printed text or 2=^-delimited)" D ^DIR K DIR Q:Y'>0 S PRNTFRMT=Y 13 S DIR(0)="Y",DIR("B")="YES",DIR("A")="Sort by SERVICE/SECTION"_$S(XUSDIV>0:" (as well)",1:"") D ^DIR K DIR Q:Y="^" S XUSSORT=+Y 14 W !!,">>> Report processing time is approximately 10 minutes." 15 W !," Recommend text output be queued to a network printer." 16 W ! 17 S %ZIS="MQ" D ^%ZIS Q:POP 18 I $D(IO("Q")) S ZTSAVE("OPTION")="",ZTSAVE("XUSSORT")="",ZTSAVE("XUSDIV")="",ZTSAVE("PRNTFRMT")="",ZTIO=ION,ZTRTN="DQ^XUSNPIE2",ZTDESC="NPI PRINT JOB FOR OPTION "_OPTION D ^%ZTLOAD W:$D(ZTSK) !,"Queued as Task "_ZTSK D HOME^%ZIS Q 19 ; 20 DQ ; entry point for queued print job 21 U IO D PRNTPROV(OPTION,XUSSORT,XUSDIV,PRNTFRMT) 22 U IO D ^%ZISC 23 Q 24 ; 25 PRNTPROV(OPTION,XUSSORT,XUSDIV,PRNTFRMT) ; 26 ; PRINT PROVIDER INFO 27 ; 28 ; OPTION SPECIFIES TYPE OF PRINT - 1=ALL PROVIDERS, 2=NEEDS NPI ONLY 29 ; XUSSORT INDICATES WHETHER SORTED BY SERVICE/SECTION 30 ; XUSDIV INDICATES WHETHER SORTED BY DIVISION 31 ; PRNTFRMT INDICATES TYPE OF OUTPUT, PRINTED OR ^-DELIMITED 32 ; 33 ; ZEXCEPT: IOSL - KERNEL VARIABLE 34 N PAGENUM,LINENUM,PROVNAME,TAXDESCR,TAXONOMY,SERVSECT,DIRUT,DTOUT 35 N GLOBLOC,IEN,NPI,DATETIME,GLOBVALU,NCOUNT,GLOBLOC1,XUSDIVNM,CNTTOTAL,CNTNONE,CNTEXMPT,CNTDONE,MULTDIV,MULTDIVC 36 S CNTTOTAL=0,CNTNONE=0,CNTEXMPT=0,CNTDONE=0 37 S PAGENUM=0,LINENUM=0 38 S DATETIME=$$NOW^XLFDT() 39 S GLOBLOC1=$$GETDATA(OPTION,XUSSORT,XUSDIV) 40 I PRNTFRMT'=1 W !,"PROVIDER_NAME^LAST4^IEN^NPI^TAXONOMY_CODE^TAXONOMY DESCRIPTION"_$S(XUSDIV:"^DIVISION",1:"")_$S(XUSSORT:"^SERVICE/SECTION",1:"") 41 S GLOBLOC=GLOBLOC1,XUSDIVNM="" F S XUSDIVNM=$O(@GLOBLOC1@(XUSDIVNM)) Q:XUSDIVNM="" D Q:$D(DIRUT)!$D(DTOUT) 42 . S SERVSECT="" F S SERVSECT=$O(@GLOBLOC1@(XUSDIVNM,SERVSECT)) Q:SERVSECT="" S GLOBLOC=$NA(@GLOBLOC1@(XUSDIVNM,SERVSECT)) D Q:$D(DIRUT)!$D(DTOUT) 43 . . I PRNTFRMT=1 D HEADER(OPTION,DATETIME,.PAGENUM,.LINENUM,XUSDIV,XUSDIVNM,XUSSORT,SERVSECT) Q:$D(DIRUT)!$D(DTOUT) 44 . . S PROVNAME="" F S PROVNAME=$O(@GLOBLOC@(PROVNAME)) Q:PROVNAME="" Q:$D(DIRUT)!$D(DTOUT) S IEN=0 F S IEN=$O(@GLOBLOC@(PROVNAME,IEN)) Q:IEN'>0 D Q:$D(DIRUT)!$D(DTOUT) 45 . . . S NCOUNT=0 46 . . . S TAXDESCR="" F S TAXDESCR=$O(@GLOBLOC@(PROVNAME,IEN,TAXDESCR)) Q:TAXDESCR="" S GLOBVALU=@GLOBLOC@(PROVNAME,IEN,TAXDESCR) D 47 . . . . S NPI=$P(GLOBVALU,U,3),TAXONOMY=$P(GLOBVALU,U,4) I PRNTFRMT=1 S NCOUNT=NCOUNT+1 W:NCOUNT=1 !,PROVNAME,?33,$$ALIGNRGT(IEN,11),?49,NPI W !,?6,TAXONOMY," ",TAXDESCR 48 . . . . I PRNTFRMT'=1 W !,PROVNAME_U_$E($$GET1^DIQ(200,IEN_",",9),6,9)_U_IEN_U_NPI_U_TAXONOMY_U_TAXDESCR_$S(XUSDIV:U_XUSDIVNM,1:"")_$S(XUSSORT:U_SERVSECT,1:"") 49 . . . . Q 50 . . . I PRNTFRMT=1 S LINENUM=LINENUM+NCOUNT+1 I LINENUM>(IOSL-4) D HEADER(OPTION,DATETIME,.PAGENUM,.LINENUM,XUSDIV,XUSDIVNM,XUSSORT,SERVSECT) Q:$D(DIRUT)!$D(DTOUT) 51 . . . Q 52 . . Q 53 . Q 54 I '($D(DIRUT)!$D(DTOUT)),PRNTFRMT=1 D 55 . S PROVNAME="" I $O(@GLOBLOC@(PROVNAME))="" W !,?20,"* * * N O D A T A F O U N D * * *",!! I 1 56 . E D 57 . . W !!,"Total Billable Providers:",?43,CNTTOTAL,!,"Billable Providers with an NPI:",?43,CNTDONE,!,"EXEMPT Billable Providers:",?43,CNTEXMPT,!,"Billable Providers Still Needing an NPI:",?43,CNTNONE 58 . . I $G(MULTDIV)>0 W !!,MULTDIV," Providers were repeated a total of ",MULTDIVC," times",!," due to listing under multiple divisions" 59 . . Q 60 . W !!,?27,"*** End of Report ***" 61 . Q 62 Q 63 ; 64 HEADER(OPTION,DATETIME,PAGNOREF,LINNOREF,XUSDIV,XUSDIVNM,XUSSORT,SERVSECT) ; 65 ; ZEXCEPT: IOF,IOST KERNEL IO VARIABLES 66 ; ZEXCEPT: DIRUT,DTOUT NEWED IN CALLING PRNTPROV - INDICATE QUIT TO PRNTPROV 67 N TEMPVAL,DIR,X,Y 68 S PAGNOREF=PAGNOREF+1 69 ; Don't page feed on the first page 70 IF PAGNOREF>1 I $E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR I 'Y S DIRUT=1 Q 71 IF PAGNOREF>1 W @IOF 72 W:$E(IOST,1,2)'="C-" ! W "Active Provider Report",?48,$$FMTE^XLFDT(DATETIME)," Page: ",PAGNOREF 73 W !," Report Option: Provider List Active Providers",$S(OPTION=2:" Without NPI Numbers",1:"") 74 W !!,"Provider Name",?39,"IEN",?49,$S(OPTION'=2:"NPI",1:"") 75 W !," Taxonomy" 76 W !,"--------------------------------------------------------------------------------" 77 S LINNOREF=6 78 I XUSDIV W !,"DIVISION: ",XUSDIVNM," " S LINNOREF=LINNOREF+1 79 I XUSSORT W:'XUSDIV ! W "SERVICE/SECTION: ",SERVSECT S:'XUSDIV LINNOREF=LINNOREF+1 80 Q 81 ; 82 GETDATA(OPTION,XUSSORT,XUSDIV) ; get data for reports for providers 83 N NPI,PROVNAME,TAXDESCR,TAXONOMY,XUSDEFLT,XUSDIVCN,XUSDIVN,XUSDIVNM,XUSGLOB 84 N XUSIEN,XUSSERVC,XUSVAL,CNTCLEAN 85 ; ZEXCEPT: CNTTOTAL,CNTNONE,CNTEXMPT,CNTDONE - NEWed and initialized in PRNTPROV or killed based on CNTCLEAN 86 S CNTCLEAN=0 I '$D(CNTTOTAL) S CNTCLEAN=1 87 S XUSGLOB=$NA(^TMP($J,"XUSNPIPRNT")) K @XUSGLOB 88 I 'XUSDIV S XUSDIVNM(1)=" ",XUSDEFLT=" " 89 I XUSDIV S XUSDEFLT=$$NS^XUAF4($$KSP^XUPARAM("INST")),XUSDEFLT=$P(XUSDEFLT,U) 90 I 'XUSSORT S XUSSERVC=" " 91 F XUSIEN=0:0 S XUSIEN=$O(^VA(200,XUSIEN)) Q:XUSIEN'>0 I ($$ACTIVE^XUSER(XUSIEN)'=""),($P($$ACTIVE^XUSER(XUSIEN),"^",2)'="TERMINATED") S XUSVAL=$$CHEKNPI^XUSNPIED(XUSIEN),XUSVAL=$$NPISTATS^XUSNPIED(XUSIEN) I XUSVAL'="" D 92 . S PROVNAME=$$GET1^DIQ(200,XUSIEN_",",.01),NPI=$$GETNPI^XUSNPIED(XUSIEN),TAXONOMY=$$GETTAXON^XUSNPIED(XUSIEN,.TAXDESCR) I TAXONOMY=-1 S TAXONOMY=" ",TAXDESCR=" " 93 . I NPI="",$$EXMPTNPI^XUSNPIED(XUSIEN) S NPI="EXEMPTED " 94 . S CNTTOTAL=$G(CNTTOTAL)+1 S:NPI="" CNTNONE=$G(CNTNONE)+1 S:NPI="EXEMPTED " CNTEXMPT=$G(CNTEXMPT)+1 S:NPI?10N CNTDONE=$G(CNTDONE)+1 95 . I '((XUSVAL="N")!(OPTION'=2)) Q 96 . I XUSSORT S XUSSERVC=$$GET1^DIQ(200,XUSIEN_",",29) I XUSSERVC="" S XUSSERVC=" " 97 . I XUSDIV D 98 . . K XUSDIVNM S XUSDIVCN=0,XUSDIVNM(1)=XUSDEFLT 99 . . F XUSDIVN=0:0 S XUSDIVN=$O(^VA(200,XUSIEN,2,XUSDIVN)) Q:XUSDIVN'>0 S XUSDIVCN=XUSDIVCN+1,XUSDIVNM(XUSDIVCN)=$$GET1^DIQ(200.02,XUSDIVN_","_XUSIEN_",",.01) 100 . . I XUSDIVCN>1 S MULTDIV=$G(MULTDIV)+1,MULTDIVC=$G(MULTDIVC)+XUSDIVCN-1 101 . . Q 102 . F XUSDIVN=0:0 S XUSDIVN=$O(XUSDIVNM(XUSDIVN)) Q:XUSDIVN'>0 S @XUSGLOB@(XUSDIVNM(XUSDIVN),XUSSERVC,PROVNAME,XUSIEN,TAXDESCR)=PROVNAME_U_XUSIEN_U_NPI_U_TAXONOMY_U_TAXDESCR 103 . Q 104 I CNTCLEAN K CNTTOTAL,CNTNONE,CNTEXMPT,CNTDONE 105 Q XUSGLOB 106 ; 107 ALIGNRGT(TEXT,WIDTH) ; align text right in a specified width 108 N RESULT 109 S $P(RESULT," ",WIDTH)=" ",RESULT=RESULT_TEXT,RESULT=$E(RESULT,$L(RESULT)-WIDTH+1,$L(RESULT)) 110 Q RESULT 111 ; 112 CHKOLD1(IEN) ; check for earlier value, and activate if present 113 N IEN1,STATUS,NPI,DATE,XUFDA 114 S IEN1=$O(^VA(200,IEN,"NPISTATUS"," "),-1) I IEN1>0 D I STATUS=0 D CHKOLD1(IEN) 115 . S STATUS=^VA(200,IEN,"NPISTATUS",IEN1,0),NPI=$P(STATUS,U,3),DATE=$P(STATUS,U),STATUS=$P(STATUS,U,2) 116 . I STATUS=0 D DELETNPI(IEN,IEN1,DATE) Q ; entry making it INACTIVE - remove it 117 . I STATUS=1 D SET^XUSNPIE1(IEN,NPI) 118 . Q 119 Q 120 ; 121 DELETNPI(IEN,OIEN,ODATEVAL) ; 122 N XUFDA 123 I $D(ODATEVAL) S XUFDA(200.042,OIEN_","_IEN_",",.01)="@" 124 S XUFDA(200,IEN_",",41.99)="@",XUFDA(200,IEN_",",41.98)="@" 125 D FILE^DIE("","XUFDA") 126 Q 127 ; 128 CLERXMPT ; edit entry indicating whether a provider is exempt from needing an NPI 129 N DIC,DIR,FDA,IEN,Y 130 W ! S DIC="^VA(200,",DIC(0)="AEQ" S DIC("A")="select Provider: " D ^DIC Q:Y'>0 S IEN=+Y 131 I $$HASNPI^XUSNPIED(IEN) W !,"This Provider already has an NPI value. Nothing to do." Q 132 I '$$CHEKNPI^XUSNPIED(IEN),'$$EXMPTNPI^XUSNPIED(IEN) W !,"This Provider does not appear to need an NPI or Exemption." Q 133 I $$EXMPTNPI^XUSNPIED(IEN) D Q ; currently marked as Exempt 134 . S DIR(0)="Y",DIR("A")="Provider is currently EXEMPT from needing an NPI, set to NEEDS an NPI (Y/N)" D ^DIR I 'Y Q 135 . S FDA(200,IEN_",",41.98)="N" D FILE^DIE("","FDA") 136 . W !,$S($$NEEDSNPI^XUSNPIED(IEN):"File updated",1:"Ecountered a problem updating file, status NOT set to NEEDS an NPI") 137 . Q 138 ; check to make sure provider should be exempt 139 S DIR(0)="Y",DIR("A")="Confirm that Provider should be Exempt from needing an NPI (Y/N)" D ^DIR I 'Y Q 140 ; and update file to show as exempt 141 S FDA(200,IEN_",",41.98)="E" D FILE^DIE("","FDA") 142 W !,$S($$EXMPTNPI^XUSNPIED(IEN):"File updated",1:"Ecountered a problem updating file, status NOT set to EXEMPT") 143 Q -
WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPIED.m
r613 r623 1 XUSNPIED ;FO-OAKLAND/JLI - DATA ENTRY FOR INITIAL NPI VALUES ;6/3/08 17:19 2 ;;8.0;KERNEL;**420,410,435,480**;Jul 10, 1995;Build 38 3 ;;Per VHA Directive 2004-038, this routine should not be modified 4 Q 5 ; 6 SIGNON ; run at user sign-on to display message if NPI value is needed. 7 D SIGNON^XUSNPIE1 8 Q 9 ; 10 CLEREDIT ; Input editing of NPI value for clerical staff - ask provider 11 N IEN,DIC,PROVNAME,DATEVAL,DESCRIP,DONE,IENS,NPIVAL1,NPIVAL2,Y,XX 12 F W ! S DIC="^VA(200,",DIC(0)="AEQ" S DIC("A")="Select Provider: " D ^DIC Q:Y'>0 S IEN=+Y D EDITNPI(IEN) 13 Q 14 ; 15 USEREDIT ; Entry point for provider to enter own data 16 I $$NPISTATS(DUZ)="" W !,$C(7),"Please see your local NPI facilitator to add the NPI",! H 3 Q 17 D EDITNPI(DUZ) 18 Q 19 ; 20 EDITNPI(IEN) ; 21 D EDITNPI^XUSNPIE3(IEN) 22 Q 23 ; 24 EDRLNPI(IEN) ; Edit AUTHORIZES RELEASE OF NPI field 25 ; NOTE: *** This field is no longer being used, and should always be set to YES 05/13/08 tkw*** 26 Q:$P($G(^VA(200,+$G(IEN),"NPI")),U,3)=1 27 N DIE,DR,DA S DIE="^VA(200,",DA=IEN,DR="41.97////1" D ^DIE 28 Q 29 ; 30 CLERXMPT ; 31 D CLERXMPT^XUSNPIE1 32 Q 33 ; 34 CHKGLOB() ; returns global location of TAXONOMY values also rebuilds if they are missing 35 Q $$CHKGLOB^XUSNPIDA() 36 ; 37 DOUSER(XUUSER,XUGLOB) ; check user for needing an NPI status value 38 N PCLASS,XUDONE,PVAL,CODE,NPISTATS,XUVALUE,D0,EXPIRATN,I,NPIFLD,NPISUBFL 39 S NPISTATS=41.98,NPISUBFL=200.042,NPIFLD=.03 40 I $$GET1^DIQ(200,XUUSER_",",NPISTATS)'="" Q ; user is already flagged 41 S PCLASS=0,XUDONE=0 F S PCLASS=$O(^VA(200,XUUSER,"USC1",PCLASS)) Q:PCLASS'>0 S D0=^(PCLASS,0) D Q:XUDONE 42 . S EXPIRATN=$P(D0,U,3)>0 I EXPIRATN Q 43 . S PVAL=$P(D0,U),CODE=$$GET1^DIQ(8932.1,PVAL_",",6) I CODE'="",$D(@XUGLOB@(CODE)) D S XUDONE=1 Q 44 . . S XUVALUE="N" N NPIVAL F I=1:1 S NPIVAL=$$GET1^DIQ(NPISUBFL,I_","_XUUSER_",",NPIFLD) Q:NPIVAL="" S XUVALUE="D" Q 45 . . N XUFDA S XUFDA(200,XUUSER_",",NPISTATS)=XUVALUE 46 . . D FILE^DIE("","XUFDA") 47 . . Q 48 . Q 49 Q 50 ; 51 CBOLIST ; list ^ delimited output to CBO exchange mail group. 52 N DATE,DOMAIN,ADDRESS,STATNAME,COUNT,GLOBLOC,GLOBOUT 53 N IEN,NPI,PROVNAME,TAXDESCR,TAXONOMY,STATION,STATUS,OPTION 54 I '$$PROD^XUPROD() Q ; messages from production systems only 55 S DATE=(1700+$E(DT,1,3))_"-"_$E(DT,4,5)_"-"_$E(DT,6,7) 56 S DOMAIN=$G(^XTV(8989.3,1,0)),DOMAIN=$P(DOMAIN,U) 57 S STATION=$$NS^XUAF4($$KSP^XUPARAM("INST")) 58 S ADDRESS=$P(STATION,U) ;$$GET1^DIQ(4.2,DOMAIN_",",.01) 59 S STATION=$P(STATION,U,2) ;$$GET1^DIQ(4.2,DOMAIN_",",5.5) 60 S OPTION=3 61 S GLOBLOC=$$GETDATA(OPTION,0,0) ; get most of data into location specified by GLOBLOC 62 S COUNT=0,GLOBOUT=$NA(^TMP($J,"XUSNPIOUT")) K @GLOBOUT 63 S COUNT=1,@GLOBOUT@(COUNT)="--START" 64 S GLOBLOC=$NA(@GLOBLOC@(" "," ")) 65 S PROVNAME="" F S PROVNAME=$O(@GLOBLOC@(PROVNAME)) Q:PROVNAME="" S IEN=0 F S IEN=$O(@GLOBLOC@(PROVNAME,IEN)) Q:IEN'>0 D 66 . S TAXDESCR="" F S TAXDESCR=$O(@GLOBLOC@(PROVNAME,IEN,TAXDESCR)) Q:TAXDESCR="" S TAXONOMY=$P(^(TAXDESCR),U,4),NPI=$P(^(TAXDESCR),U,3) D 67 . . S STATUS=$$NPISTATS(IEN) 68 . . S COUNT=COUNT+1,@GLOBOUT@(COUNT)=PROVNAME_U_STATION_U_NPI_U_TAXONOMY_U_TAXDESCR_U_DATE_U_STATUS 69 . . Q 70 . Q 71 S COUNT=COUNT+1,@GLOBOUT@(COUNT)="--END" 72 ; and generate mail message 73 N XMTEXT,XMDUZ,XMY,XMSUB 74 S XMTEXT=$E(GLOBOUT,1,$L(GLOBOUT)-1)_",",XMDUZ=0.5,XMY("VHACONPINPF@VA.GOV")="" 75 S XMSUB="NPI LIST "_DATE_" FOR "_ADDRESS_" ("_STATION_")" 76 D ^XMD 77 Q 78 ; 79 PRINTOPT ; 80 D PRINTOPT^XUSNPIE2 81 Q 82 GETDATA(OPTION,XUSSORT,XUSDIV) ; get data for reports for providers 83 Q $$GETDATA^XUSNPIE2(OPTION,XUSSORT,XUSDIV) 84 ; 85 CHEKNPI(IEN) ; returns whether status is Needs, will check and update if not set 86 N VALUE,FDA 87 S VALUE=$E($$GET1^DIQ(200,IEN_",",41.98)) 88 I VALUE="N" S FDA(200,IEN_",",41.98)="" D FILE^DIE("","FDA") S VALUE="" ; XU*8*435 JLI 89 I VALUE="",$$CHKTAXON(IEN) K FDA S FDA(200,IEN_",",41.98)="N" D FILE^DIE("","FDA") S VALUE="N" 90 Q VALUE="N" 91 ; 92 NEEDSNPI(IEN) ; returns whether current status is N 93 Q $$NPISTATS(IEN)="N" 94 ; 95 HASNPI(IEN) ; returns whether current status is D (Done) 96 Q $$NPISTATS(IEN)="D" 97 ; 98 EXMPTNPI(IEN) ; returns whether current status is E (Exempt) 99 Q $$NPISTATS(IEN)="E" 100 ; 101 NPISTATS(IEN) ; returns one letter status indicator 102 N VAL 103 S VAL=$E($$GET1^DIQ(200,IEN_",",41.98)) 104 I (VAL="")!(VAL="N") S VAL=$$CHEKNPI(IEN) 105 Q $E($$GET1^DIQ(200,IEN_",",41.98)) 106 ; 107 GETNPI(IEN) ; returns current NPI value 108 Q $$GET1^DIQ(200,IEN_",",41.99) 109 ; 110 GETTAXON(IEN,DESCRREF) ; returns Taxonomy value (X12) and sets description in DESCRREF, otherwise -1 111 N I,POINTER,TAXON 112 S TAXON=-1,DESCRREF=" " 113 ;F I=0:0 S I=$O(^VA(200,IEN,"USC1",I)) Q:I'>0 I $P(^(I,0),U,3)'>0 S POINTER=+^(0) S TAXON=$$GET1^DIQ(8932.1,POINTER_",",6),DESCRREF=$$GET1^DIQ(8932.1,POINTER_",",1) Q 114 S POINTER=+$$GET^XUA4A72(IEN) I POINTER>0 S TAXON=$$GET1^DIQ(8932.1,POINTER_",",6),DESCRREF=$$GET1^DIQ(8932.1,POINTER_",",1) ; XU*8*435 make sure active on today 115 I TAXON="" S TAXON=-1,DESCRREF=" " 116 Q TAXON 117 ; 118 CHKTAXON(IEN,TAXONOMY) ; checks whether taxonomy value (X12) is in list of billable otherwise 0-1 119 N DESCRIP,XUSGLOB 120 I $G(TAXONOMY)="" S TAXONOMY=$$GETTAXON(IEN,.DESCRIP) 121 S XUSGLOB=$$CHKGLOB() 122 Q $D(@XUSGLOB@(TAXONOMY)) 123 ; 124 DATE10(DATE) ; returns date in mm/dd/yyyyy format 125 Q $E(DATE,4,5)_"/"_$E(DATE,6,7)_"/"_(1700+$E(DATE,1,3)) 126 ; 127 POSTINIT ; runs post init 128 D POSTINIT^XUSNPIE1 129 Q 130 ; 131 CBOQUEUE ; queues CBO List to run on first day of month 132 D CBOQUEUE^XUSNPIE1 133 Q 134 ALIGNRGT(TEXT,WIDTH) ; align text right in a specified width 135 Q $$ALIGNRGT^XUSNPIE2(TEXT,WIDTH) 1 XUSNPIED ;FO-OAKLAND/JLI - DATA ENTRY FOR INITIAL NPI VALUES ;11/20/06 11:20 2 ;;8.0;KERNEL;**420,410,435**;Jul 10, 1995;Build 10 3 Q 4 ; 5 SIGNON ; run at user sign-on to display message if NPI value is needed. 6 D SIGNON^XUSNPIE1 7 Q 8 ; 9 CLEREDIT ; Input editing of NPI value for clerical staff - ask provider 10 N IEN,DIC,PROVNAME,DATEVAL,DESCRIP,DONE,IENS,NPIVAL1,NPIVAL2,Y,XX 11 F W ! S DIC="^VA(200,",DIC(0)="AEQ" S DIC("A")="Select Provider: " D ^DIC Q:Y'>0 S IEN=+Y D EDITNPI(IEN) 12 Q 13 ; 14 USEREDIT ; Entry point for provider to enter own data 15 I $$NPISTATS(DUZ)="" W !,$C(7),"Please see your local NPI facilitator to add the NPI",! H 3 Q 16 D EDITNPI(DUZ) 17 Q 18 ; 19 EDITNPI(IEN) ; 20 D EDITNPI^XUSNPIE1(IEN) 21 Q 22 ; 23 CLERXMPT ; 24 D CLERXMPT^XUSNPIE1 25 Q 26 ; 27 CHKGLOB() ; returns global location of TAXONOMY values also rebuilds if they are missing 28 Q $$CHKGLOB^XUSNPIDA() 29 ; 30 DOUSER(XUUSER,XUGLOB) ; check user for needing an NPI status value 31 N PCLASS,XUDONE,PVAL,CODE,NPISTATS,XUVALUE,D0,EXPIRATN,I,NPIFLD,NPISUBFL 32 S NPISTATS=41.98,NPISUBFL=200.042,NPIFLD=.03 33 I $$GET1^DIQ(200,XUUSER_",",NPISTATS)'="" Q ; user is already flagged 34 S PCLASS=0,XUDONE=0 F S PCLASS=$O(^VA(200,XUUSER,"USC1",PCLASS)) Q:PCLASS'>0 S D0=^(PCLASS,0) D Q:XUDONE 35 . S EXPIRATN=$P(D0,U,3)>0 I EXPIRATN Q 36 . S PVAL=$P(D0,U),CODE=$$GET1^DIQ(8932.1,PVAL_",",6) I CODE'="",$D(@XUGLOB@(CODE)) D S XUDONE=1 Q 37 . . S XUVALUE="N" N NPIVAL F I=1:1 S NPIVAL=$$GET1^DIQ(NPISUBFL,I_","_XUUSER_",",NPIFLD) Q:NPIVAL="" S XUVALUE="D" Q 38 . . N XUFDA S XUFDA(200,XUUSER_",",NPISTATS)=XUVALUE 39 . . D FILE^DIE("","XUFDA") 40 . . Q 41 . Q 42 Q 43 ; 44 CBOLIST ; list ^ delimited output to CBO exchange mail group. 45 N DATE,DOMAIN,ADDRESS,STATNAME,COUNT,DOB,GLOBLOC,GLOBOUT 46 N IEN,NPI,PROVNAME,SSN,TAXDESCR,TAXONOMY,STATION,STATUS,OPTION 47 I '$$PROD^XUPROD() Q ; messages from production systems only 48 S DATE=(1700+$E(DT,1,3))_"-"_$E(DT,4,5)_"-"_$E(DT,6,7) 49 S DOMAIN=$G(^XTV(8989.3,1,0)),DOMAIN=$P(DOMAIN,U) 50 S STATION=$$NS^XUAF4($$KSP^XUPARAM("INST")) 51 S ADDRESS=$P(STATION,U) ;$$GET1^DIQ(4.2,DOMAIN_",",.01) 52 S STATION=$P(STATION,U,2) ;$$GET1^DIQ(4.2,DOMAIN_",",5.5) 53 S OPTION=3 54 S GLOBLOC=$$GETDATA(OPTION,0,0) ; get most of data into location specified by GLOBLOC 55 S COUNT=0,GLOBOUT=$NA(^TMP($J,"XUSNPIOUT")) K @GLOBOUT 56 S COUNT=1,@GLOBOUT@(COUNT)="--START" 57 S GLOBLOC=$NA(@GLOBLOC@(" "," ")) 58 S PROVNAME="" F S PROVNAME=$O(@GLOBLOC@(PROVNAME)) Q:PROVNAME="" S IEN=0 F S IEN=$O(@GLOBLOC@(PROVNAME,IEN)) Q:IEN'>0 D 59 . S TAXDESCR="" F S TAXDESCR=$O(@GLOBLOC@(PROVNAME,IEN,TAXDESCR)) Q:TAXDESCR="" S TAXONOMY=$P(^(TAXDESCR),U,4),NPI=$P(^(TAXDESCR),U,3) D 60 . . S DOB=$P($G(^VA(200,IEN,1)),U,3),SSN=$E($$GET1^DIQ(200,IEN_",",9),6,9) S:DOB'="" DOB=$$DATE10(DOB) S STATUS=$$NPISTATS(IEN) 61 . . S COUNT=COUNT+1,@GLOBOUT@(COUNT)=PROVNAME_U_STATION_U_NPI_U_SSN_U_DOB_U_TAXONOMY_U_TAXDESCR_U_DATE_U_STATUS 62 . . Q 63 . Q 64 S COUNT=COUNT+1,@GLOBOUT@(COUNT)="--END" 65 ; and generate mail message 66 N XMTEXT,XMDUZ,XMY,XMSUB 67 S XMTEXT=$E(GLOBOUT,1,$L(GLOBOUT)-1)_",",XMDUZ=0.5,XMY("VHACONPINPF@VA.GOV")="" 68 S XMSUB="NPI LIST "_DATE_" FOR "_ADDRESS_" ("_STATION_")" 69 D ^XMD 70 Q 71 ; 72 PRINTOPT ; 73 D PRINTOPT^XUSNPIE2 74 Q 75 GETDATA(OPTION,XUSSORT,XUSDIV) ; get data for reports for providers 76 Q $$GETDATA^XUSNPIE2(OPTION,XUSSORT,XUSDIV) 77 ; 78 CHEKNPI(IEN) ; returns whether status is Needs, will check and update if not set 79 N VALUE,FDA 80 S VALUE=$E($$GET1^DIQ(200,IEN_",",41.98)) 81 I VALUE="N" S FDA(200,IEN_",",41.98)="" D FILE^DIE("","FDA") S VALUE="" ; XU*8*435 JLI 82 I VALUE="",$$CHKTAXON(IEN) K FDA S FDA(200,IEN_",",41.98)="N" D FILE^DIE("","FDA") S VALUE="N" 83 Q VALUE="N" 84 ; 85 NEEDSNPI(IEN) ; returns whether current status is N 86 Q $$NPISTATS(IEN)="N" 87 ; 88 HASNPI(IEN) ; returns whether current status is D (Done) 89 Q $$NPISTATS(IEN)="D" 90 ; 91 EXMPTNPI(IEN) ; returns whether current status is E (Exempt) 92 Q $$NPISTATS(IEN)="E" 93 ; 94 NPISTATS(IEN) ; returns one letter status indicator 95 N VAL 96 S VAL=$E($$GET1^DIQ(200,IEN_",",41.98)) 97 I (VAL="")!(VAL="N") S VAL=$$CHEKNPI(IEN) 98 Q $E($$GET1^DIQ(200,IEN_",",41.98)) 99 ; 100 GETNPI(IEN) ; returns current NPI value 101 Q $$GET1^DIQ(200,IEN_",",41.99) 102 ; 103 GETTAXON(IEN,DESCRREF) ; returns Taxonomy value (X12) and sets description in DESCRREF, otherwise -1 104 N I,POINTER,TAXON 105 S TAXON=-1,DESCRREF=" " 106 ;F I=0:0 S I=$O(^VA(200,IEN,"USC1",I)) Q:I'>0 I $P(^(I,0),U,3)'>0 S POINTER=+^(0) S TAXON=$$GET1^DIQ(8932.1,POINTER_",",6),DESCRREF=$$GET1^DIQ(8932.1,POINTER_",",1) Q 107 S POINTER=+$$GET^XUA4A72(IEN) I POINTER>0 S TAXON=$$GET1^DIQ(8932.1,POINTER_",",6),DESCRREF=$$GET1^DIQ(8932.1,POINTER_",",1) ; XU*8*435 make sure active on today 108 I TAXON="" S TAXON=-1,DESCRREF=" " 109 Q TAXON 110 ; 111 CHKTAXON(IEN,TAXONOMY) ; checks whether taxonomy value (X12) is in list of billable otherwise 0-1 112 N DESCRIP,XUSGLOB 113 I $G(TAXONOMY)="" S TAXONOMY=$$GETTAXON(IEN,.DESCRIP) 114 S XUSGLOB=$$CHKGLOB() 115 Q $D(@XUSGLOB@(TAXONOMY)) 116 ; 117 DATE10(DATE) ; returns date in mm/dd/yyyyy format 118 Q $E(DATE,4,5)_"/"_$E(DATE,6,7)_"/"_(1700+$E(DATE,1,3)) 119 ; 120 POSTINIT ; runs post init 121 D POSTINIT^XUSNPIE1 122 Q 123 ; 124 CBOQUEUE ; queues CBO List to run on first day of month 125 D CBOQUEUE^XUSNPIE1 126 Q 127 ALIGNRGT(TEXT,WIDTH) ; align text right in a specified width 128 Q $$ALIGNRGT^XUSNPIE2(TEXT,WIDTH) -
WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPIX1.m
r613 r623 1 XUSNPIX1 ;OAK_BP/CMW - NPI EXTRACT REPORT ;11:45 AM 28 Jul 2009 2 ;;8.0;KERNEL;**438,452,453,481,WV**; Jul 10, 1995;Build 21 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 ; NPI Extract Report 6 ; 7 ; Input parameter: N/A 8 ; 9 ; Other relevant variables: 10 ; XUSRTN="XUSNPIX1" (current routine name, used for ^XTMP and ^TMP 11 ; storage subscript) 12 ; Storage Global: 13 ; ^XTMP("XUSNPIX1",0) = Piece 1^Piece 2^Piece 3^Piece 4^Piece 5^Piece 6 14 ; where: 15 ; Piece 1 => Purge Date - 1 year in future 16 ; Piece 2 => Create Date - Today 17 ; Piece 3 => Description 18 ; Piece 4 => Last Date Compiled 19 ; Piece 5 => $H last run start time 20 ; Piece 6 => $H last run completion time 21 ; 22 ; ^XTMP("XUSNPIX1",1) = DATA 23 ; 24 ; XUSNPI => Unique NPI of entry 25 ; LDT => Last Date Run, VA Fileman Format 26 ; 27 ; Entry Point - TASKMAN => Run report in background using TASKMAN 28 ; 29 Q 30 ; 31 TASKMAN ;TASKMAN ENTRY POINT 32 ; Process Report 33 N XUSRTN,DTTM,XUSPROD,XUSVER,INSMAIL 34 ; 35 ; Check for required variables 36 I $G(U)=""!($G(DT)="") G EXIT 37 S XUSRTN="XUSNPIX1" 38 S DTTM=$$HTE^XLFDT($H,"2") 39 ; Check to see if report is in use 40 L +^XTMP(XUSRTN):5 I '$T G EXIT 41 ; 42 ;Reset Summary Scratch Globals 43 K ^TMP("XUSNPIXS",$J) 44 K ^TMP("XUSNPIXT",$J) 45 ; 46 ; Initialize variables 47 D INIT(XUSRTN) 48 ; 49 ; Pull Station(Institution) data 50 D INST(XUSRTN,XUSVER,.INSMAIL) 51 ; 52 ;Process New Person File 53 D PROC1(XUSRTN,XUSPROD,XUSVER,DTTM,INSMAIL) 54 ; 55 ; Process Institution File 56 D ENT^XUSNPIX2(XUSPROD,XUSVER) 57 ; 58 ; Process Non VA File 59 D ENT^XUSNPIX3(XUSPROD,XUSVER) 60 ; 61 ; Send summary message 62 D SMAIL^XUSNPIX5("XUSNPIXT",XUSPROD,XUSVER,DTTM) 63 ; 64 ;Standard EXIT point 65 EXIT ; 66 K DTTM,XUSVER,XUSHDR,XUSPROD,INSMAIL 67 ; 68 ;Kill off Scratch Globals 69 K ^TMP("XUSNPIXS",$J) 70 K ^TMP("XUSNPIXT",$J) 71 K ^TMP("XUSNPIXU",$J) 72 ; Log Run Completion Time 73 S $P(^XTMP(XUSRTN,0),U,6)=$H 74 L -^XTMP(XUSRTN) 75 ; 76 Q 77 ; 78 INIT(XUSRTN) ; check/init variables 79 N XUSDESC 80 ; Set to NEXT release version from NPM 81 S XUSVER="481.5" 82 ; Get production/test account flag 83 S XUSPROD=$S($$PROD^XUPROD(1):"PROD",1:"TEST") 84 ; 85 ; Reset Temporary Scratch Global 86 D INIT^XUSNPIXU 87 K ^TMP(XUSRTN) 88 S XUSDESC="NPI EXTRACT TYPE 1 - Do Not Delete" 89 S ^XTMP(XUSRTN,0)=(DT+10000)_U_DT_U_XUSDESC_U_DT_U_$H 90 ; Generate TMP BCBS Array 91 D BCBSID^XUSNPIXU 92 ; 93 Q 94 ; 95 INST(XUSRTN,XUSVER,INSMAIL) ;Pull station and Institution info 96 N INST,SINFO,DIC4 97 ; Pull site info 98 S SINFO=$$SITE^VASITE 99 ; Station Number 100 S SITE=$P(SINFO,U,3) 101 ; Institution 102 S INST=$P(SINFO,U) 103 ; 104 ; Get institution mailing address 105 I INST D 106 . S DIC4=$G(^DIC(4,INST,4)) 107 . S XUSNP(7)=$P(DIC4,U) 108 . S XUSNP(8)=$P(DIC4,U,2) 109 . S XUSNP(9)=$P(DIC4,U,3) 110 . S XUSNP(10)=$P(DIC4,U,4) 111 . I XUSNP(10) S XUSNP(10)=$P($G(^DIC(5,XUSNP(10),0)),U,2) 112 . S XUSNP(11)=$P(DIC4,U,5) 113 . S INSMAIL=XUSNP(7)_U_XUSNP(8)_U_XUSNP(9)_U_XUSNP(10)_U_XUSNP(11) 114 S XUSHDR="Station: "_SITE_U_XUSNP(9)_U_XUSNP(10)_U_XUSNP(11)_U_"TYPE 1"_U_XUSVER 115 ; 116 Q 117 ; 118 PROC1(XUSRTN,XUSPROD,XUSVER,DTTM,INSMAIL) ;Process all New Person records 119 N XUSNPI,XUSDT,XUSNEW,XUSI,XUSDATA,XUSVA0,XUSVA0,XUSVA1,XUSNAME,XUSDOB,XUSDIV,XUSSTL,XUSSTLN,XUSOPN 120 N XUSPER,XUSSPC,XUSTAX,XUSTAXID,XUSIZE,NPIEN,DIC4,SPDIV,VA12,VA13,COUNT,MSGCNT,MAXSIZE,TOTREC,XUSEOL 121 ; 122 ; Set to 300000 for live 123 S MAXSIZE=300000 124 ; 125 ; Set end of line character 126 S XUSEOL="~~" 127 ; 128 ; set counter 129 S COUNT=1,(TOTREC,MSGCNT,XUSIZE)=0 130 ; Loop through NEW PERSON NPI records NPI cross ref 131 S XUSNPI=0 132 F S XUSNPI=$O(^VA(200,"ANPI",XUSNPI)) Q:'XUSNPI D 133 . S NPIEN=$O(^VA(200,"ANPI",XUSNPI,"")) 134 . ; 135 . ; Init columns 136 . F XUSI=1:1:29 S XUSNP(XUSI)="" 137 . S XUSNP(1)=XUSNPI S XUSDATA1=XUSNP(1) 138 . ; 139 . S XUSVA0=$G(^VA(200,NPIEN,0)) 140 . S XUSVA1=$G(^VA(200,NPIEN,1)) 141 . S XUSNAME=$P(XUSVA0,U) 142 . ; BREAK NAME INTO COMPONENTS 143 . I XUSNAME'="" D 144 . . ;Begin WorldVistA Change; 07/28/2009 145 . . ;S XLFNC=XUSNAME D FORMAT^XLFNAME7(.XLFNC,,,,0) 146 . . S XLFNC=XUSNAME S XLFNC=$$FORMAT^XLFNAME7(.XLFNC,,,,0) 147 . . ;End WorldVistA change 148 . . S XUSNP(2)=XLFNC("GIVEN"),XUSNP(3)=XLFNC("MIDDLE"),XUSNP(4)=XLFNC("FAMILY") 149 . . I XLFNC("SUFFIX")'="" S XUSNP(4)=XUSNP(4)_" "_XLFNC("SUFFIX") 150 . . K XLFNC 151 . S XUSDATA1=XUSDATA1_U_XUSNP(2)_U_XUSNP(3)_U_XUSNP(4) 152 . S XUSNP(5)=1 ;TYPE 153 . S XUSDOB=$P(XUSVA1,U,3) 154 . ; dob formatted as mm/dd/yyyy 155 . I XUSDOB D 156 . . S XUSNP(6)=$$FMTE^XLFDT(XUSDOB,5) 157 . S XUSDATA1=XUSDATA1_U_XUSNP(5)_U_XUSNP(6) 158 . ; 159 . ; Pay to Provider Address Use primary institution mailing address NP7-11 160 . S XUSDATA1=XUSDATA1_U_INSMAIL 161 . ; 162 . ; Servicing Provider Address 163 . S (XUSDIV)=0 164 . ; Loop through Division multiple 165 . F S XUSDIV=$O(^VA(200,NPIEN,2,XUSDIV)) Q:'XUSDIV D 166 . . S DIC4=$G(^DIC(4,XUSDIV,4)) 167 . . S XUSNP(12)=$P(DIC4,U) 168 . . S XUSNP(13)=$P(DIC4,U,2) 169 . . S XUSNP(14)=$P(DIC4,U,3) 170 . . S XUSNP(15)=$P(DIC4,U,4) 171 . . I XUSNP(15) S XUSNP(15)=$P($G(^DIC(5,XUSNP(15),0)),U,2) 172 . . S XUSNP(16)=$P(DIC4,U,5) 173 . . S XUSSTA(XUSDIV)=$P($G(^DIC(4,XUSDIV,99)),U) 174 . . S SPADR(XUSDIV)=XUSNP(12)_U_XUSNP(13)_U_XUSNP(14)_U_XUSNP(15)_U_XUSNP(16) 175 . ; If no divisions found 176 . I '$D(SPADR) D 177 . . S XUSSTA(9999)="N/A",SPADR(9999)=XUSNP(12)_U_XUSNP(13)_U_XUSNP(14)_U_XUSNP(15)_U_XUSNP(16) 178 . ; 179 . ; Office Phone number 180 . S XUSOPN=$P($G(^VA(200,NPIEN,.13)),U,2) 181 . I XUSOPN'="" S XUSNP(17)=XUSOPN 182 . ; 183 . ; Degree 184 . S XUSNP(18)=$P($G(^VA(200,NPIEN,3.1)),U,6) 185 . ; Degree Code (place holder) 186 . S XUSNP(19)="" 187 . ; 188 . ; get taxonomy and specialty 189 . S XUSPER=0 190 . F S XUSPER=$O(^VA(200,NPIEN,"USC1","B",XUSPER)) Q:'XUSPER D 191 . . S XUSSPC=$P($G(^USC(8932.1,XUSPER,0)),U,9) 192 . . S XUSTAX=$P($G(^USC(8932.1,XUSPER,0)),U,7) 193 . . I XUSSPC'="" D 194 . . . I XUSNP(20)="" S XUSNP(20)=XUSSPC Q 195 . . . S XUSNP(20)=XUSNP(20)_";"_XUSSPC 196 . . I XUSTAX'="" D 197 . . . I XUSNP(21)="" S XUSNP(21)=XUSTAX Q 198 . . . S XUSNP(21)=XUSNP(21)_";"_XUSTAX 199 . ; 200 . ; Tax ID 201 . S XUSTAXID=$P($G(^VA(200,NPIEN,"TPB")),U,2) 202 . I XUSTAXID="" S XUSTAXID=$P($G(^VA(200,NPIEN,1)),U,9) 203 . S XUSNP(22)=XUSTAXID 204 . ; 205 . S XUSDATA2=XUSNP(17)_U_XUSNP(18)_U_XUSNP(19)_U_XUSNP(20)_U_XUSNP(21)_U_XUSNP(22) 206 . ; 207 . ; Medicare Part A/B 208 . S XUSNP(23)=670899 209 . S XUSNP(24)="VA"_$E(SITE+10000,2,5) 210 . ; 211 . ; State License 212 . S XUSSTL=0 213 . F S XUSSTL=$O(^VA(200,NPIEN,"PS1",XUSSTL)) Q:'XUSSTL D 214 . . S XUSSTLN=$P($G(^VA(200,NPIEN,"PS1",XUSSTL,0)),U,2) 215 . . I XUSSTLN'="" D 216 . . . I XUSNP(25)="" S XUSNP(25)=XUSSTLN Q 217 . . . S XUSNP(25)=XUSNP(25)_";"_XUSSTLN 218 . ; DEA # 219 . S XUSNP(26)=$P($G(^VA(200,NPIEN,"PS")),U,2) 220 . ; 221 . S XUSDATA2=XUSDATA2_U_XUSNP(23)_U_XUSNP(24)_U_XUSNP(25)_U_XUSNP(26) 222 . ; 223 . ; Station # 224 . S XUSNP(27)="" 225 . ; 226 . ; Get BCBS Payer ID Array 227 . K XUSBXID 228 . D PRACID^XUSNPIXU(NPIEN,.XUSBXID) 229 . ; 230 . ; Save entry to ^TMP and update count 231 . N XUSB 232 . S XUSDIV=0 233 . F S XUSDIV=$O(SPADR(XUSDIV)) Q:'XUSDIV D 234 . . S COUNT=COUNT+1,TOTREC=TOTREC+1 235 . . S ^TMP(XUSRTN,$J,COUNT)=XUSDATA1_U_SPADR(XUSDIV)_U_XUSDATA2_U_XUSSTA(XUSDIV)_U_XUSEOL 236 . . S XUSIZE=XUSIZE+$L(^TMP(XUSRTN,$J,COUNT)) 237 . . ; Check BCBS Id array 238 . . I $D(XUSBXID) D 239 . . . S XUSB="" 240 . . . F S XUSB=$O(XUSBXID(XUSB)) Q:XUSB="" D 241 . . . . S COUNT=COUNT+1,TOTREC=TOTREC+1 242 . . . . S ^TMP(XUSRTN,$J,COUNT)=XUSDATA1_U_SPADR(XUSDIV)_U_XUSDATA2_U_XUSSTA(XUSDIV)_U_XUSB_U_XUSEOL 243 . . . . S XUSIZE=XUSIZE+$L(^TMP(XUSRTN,$J,COUNT)) 244 . K XUSNP,XUSDATA1,XUSDATA2,XUSDATA3,SPADR,XUSBXID,CNT,XUSSTA 245 . I XUSIZE>MAXSIZE D 246 . . D EOF(XUSRTN) 247 . . D EMAIL^XUSNPIX5(XUSRTN) 248 . . K ^TMP(XUSRTN,$J) 249 . . S ^TMP("XUSNPIXS",$J,1,MSGCNT)="1^"_(COUNT-2) 250 . . S ^TMP(XUSRTN,$J,1)=XUSHDR 251 . . S COUNT=1,XUSIZE=0 252 D EOF(XUSRTN) 253 ; 254 ; Send the last message (if it has records) 255 I $G(COUNT)>1 D 256 .D EMAIL^XUSNPIX5(XUSRTN) 257 .K ^TMP(XUSRTN,$J) 258 .S ^TMP("XUSNPIXS",$J,1,MSGCNT)="1^"_(COUNT-2) 259 ; 260 ; Set summary totals 261 S ^XTMP("XUSNPIXT",0)=(DT+10000)_U_DT_U_"NPI EXTRACT SUMMARY TOTALS"_U_DT_U_$H 262 S ^XTMP("XUSNPIXT","H")=$P(XUSHDR,U,1,4) 263 S ^XTMP("XUSNPIXT",1)=MSGCNT_U_TOTREC_U_DTTM 264 K INSMAIL,SITE 265 Q 266 ; 267 EOF(XUSRTN) ; 268 Q:COUNT=1 269 S MSGCNT=MSGCNT+1 270 S ^TMP(XUSRTN,$J,1)=XUSHDR_U_"Message Number: "_MSGCNT_U_"Line Count: "_COUNT_U_DTTM_U_$G(XUSPROD)_U_XUSEOL 271 S COUNT=COUNT+1 272 S ^TMP(XUSRTN,$J,COUNT)="END OF FILE"_U_XUSEOL 273 Q 1 XUSNPIX1 ;OAK_BP/CMW - NPI EXTRACT REPORT ;01-OCT-06 2 ;;8.0;KERNEL;**438,452,453**; Jul 10, 1995;Build 36 3 ;;Per VHA Directive 10-93-142, this routine should not be modified. 4 ; 5 ; NPI Extract Report 6 ; 7 ; Input parameter: N/A 8 ; 9 ; Other relevant variables: 10 ; XUSRTN="XUSNPIX1" (current routine name, used for ^XTMP and ^TMP 11 ; storage subscript) 12 ; Storage Global: 13 ; ^XTMP("XUSNPIX1",0) = Piece 1^Piece 2^Piece 3^Piece 4^Piece 5^Piece 6 14 ; where: 15 ; Piece 1 => Purge Date - 1 year in future 16 ; Piece 2 => Create Date - Today 17 ; Piece 3 => Description 18 ; Piece 4 => Last Date Compiled 19 ; Piece 5 => $H last run start time 20 ; Piece 6 => $H last run completion time 21 ; 22 ; ^XTMP("XUSNPIX1",1) = DATA 23 ; 24 ; XUSNPI => Unique NPI of entry 25 ; LDT => Last Date Run, VA Fileman Format 26 ; 27 ; Entry Point - TASKMAN => Run report in background using TASKMAN 28 ; 29 Q 30 ; 31 TASKMAN ;TASKMAN ENTRY POINT 32 ; Process Report 33 N XUSRTN,DTTM 34 ; Check for required variables 35 I $G(U)=""!($G(DT)="") G EXIT 36 S XUSRTN="XUSNPIX1" 37 S DTTM=$$HTE^XLFDT($H,"2") 38 ; Check to see if report is in use 39 L +^XTMP(XUSRTN):5 I '$T G EXIT 40 ; 41 D INIT(XUSRTN) 42 ; Pull Station(Institution) data 43 D INST(XUSRTN) 44 ; 45 D PROC1(XUSRTN) 46 ; Send the message 47 D EMAIL^XUSNPIX5(XUSRTN) 48 D VMAIL^XUSNPIX5(XUSRTN) 49 ; 50 ; Process Institution File 51 D ENT^XUSNPIX2 52 ; 53 ; Process Non VA File 54 D ENT^XUSNPIX3 55 ; 56 ; Send summary message 57 D SMAIL^XUSNPIX5("XUSNPIXT") 58 ; 59 ;Standard EXIT point 60 EXIT ; 61 K XUSEOL,DTTM,MAXSIZE,XUSVER,XUSHDR,XUSPROD 62 K MSGCNT,TOTREC,COUNT 63 K ^TMP("XUSNPIXU",$J) 64 ; Log Run Completion Time 65 S $P(^XTMP(XUSRTN,0),U,6)=$H 66 L -^XTMP(XUSRTN) 67 ; 68 Q 69 ; 70 INIT(XUSRTN) ; check/init variables 71 N XUSDESC 72 ; Set to NEXT release version from NPM 73 S XUSVER="453.16" 74 ; Get production/test account flag 75 S XUSPROD=$S($$PROD^XUPROD(1):"PROD",1:"TEST") 76 ; Set end of line character 77 S XUSEOL="~~" 78 ; Set to 300000 for live 79 S MAXSIZE=300000 80 ; Reset Temporary Scratch Global 81 D INIT^XUSNPIXU 82 K ^TMP(XUSRTN) 83 S XUSDESC="NPI EXTRACT TYPE 1 - Do Not Delete" 84 S ^XTMP(XUSRTN,0)=(DT+10000)_U_DT_U_XUSDESC_U_DT_U_$H 85 ; Generate TMP BCBS Array 86 D BCBSID^XUSNPIXU 87 ; 88 Q 89 ; 90 INST(XUSRTN) ;Pull station and Institution info 91 N INST,SINFO,DIC4 92 ; Pull site info 93 S SINFO=$$SITE^VASITE 94 ; Station Number 95 S SITE=$P(SINFO,U,3) 96 ; Institution 97 S INST=$P(SINFO,U) 98 ; 99 ; Get institution mailing address 100 I INST D 101 . S DIC4=$G(^DIC(4,INST,4)) 102 . S XUSNP(7)=$P(DIC4,U) 103 . S XUSNP(8)=$P(DIC4,U,2) 104 . S XUSNP(9)=$P(DIC4,U,3) 105 . S XUSNP(10)=$P(DIC4,U,4) 106 . I XUSNP(10) S XUSNP(10)=$P($G(^DIC(5,XUSNP(10),0)),U,2) 107 . S XUSNP(11)=$P(DIC4,U,5) 108 . S INSMAIL=XUSNP(7)_U_XUSNP(8)_U_XUSNP(9)_U_XUSNP(10)_U_XUSNP(11) 109 S XUSHDR="Station: "_SITE_U_XUSNP(9)_U_XUSNP(10)_U_XUSNP(11)_U_"TYPE 1"_U_XUSVER 110 ; 111 Q 112 ; 113 PROC1(XUSRTN) ;Process all New Person records 114 N XUSNPI,XUSDT,XUSNEW,XUSI,XUSDATA,XUSVA0,XUSVA0,XUSVA1,XUSNAME,XUSDOB,XUSDIV,XUSSTL,XUSSTLN,XUSOPN 115 N XUSPER,XUSSPC,XUSTAX,XUSTAXID,XUSIZE,NPIEN,DIC4,SPDIV,VA12,VA13 116 ; set counter 117 S COUNT=1,(TOTREC,MSGCNT,XUSIZE)=0 118 ; Loop through NEW PERSON NPI records NPI cross ref 119 S XUSNPI=0 120 F S XUSNPI=$O(^VA(200,"ANPI",XUSNPI)) Q:'XUSNPI D 121 . S NPIEN=$O(^VA(200,"ANPI",XUSNPI,"")) 122 . ; 123 . ; Init columns 124 . F XUSI=1:1:29 S XUSNP(XUSI)="" 125 . S XUSNP(1)=XUSNPI S XUSDATA1=XUSNP(1) 126 . ; 127 . S XUSVA0=$G(^VA(200,NPIEN,0)) 128 . S XUSVA1=$G(^VA(200,NPIEN,1)) 129 . S XUSNAME=$P(XUSVA0,U) 130 . ; BREAK NAME INTO COMPONENTS 131 . I XUSNAME'="" D 132 . . S XLFNC=XUSNAME D FORMAT^XLFNAME7(.XLFNC,,,,0) 133 . . S XUSNP(2)=XLFNC("GIVEN"),XUSNP(3)=XLFNC("MIDDLE"),XUSNP(4)=XLFNC("FAMILY") 134 . . I XLFNC("SUFFIX")'="" S XUSNP(4)=XUSNP(4)_" "_XLFNC("SUFFIX") 135 . . K XLFNC 136 . S XUSDATA1=XUSDATA1_U_XUSNP(2)_U_XUSNP(3)_U_XUSNP(4) 137 . S XUSNP(5)=1 ;TYPE 138 . S XUSDOB=$P(XUSVA1,U,3) 139 . ; dob formatted as mm/dd/yyyy 140 . I XUSDOB D 141 . . S XUSNP(6)=$$FMTE^XLFDT(XUSDOB,5) 142 . S XUSDATA1=XUSDATA1_U_XUSNP(5)_U_XUSNP(6) 143 . ; 144 . ; Pay to Provider Address Use primary institution mailing address NP7-11 145 . S XUSDATA1=XUSDATA1_U_INSMAIL 146 . ; 147 . ; Servicing Provider Address 148 . S (XUSDIV)=0 149 . ; Loop through Division multiple 150 . F S XUSDIV=$O(^VA(200,NPIEN,2,XUSDIV)) Q:'XUSDIV D 151 . . S DIC4=$G(^DIC(4,XUSDIV,4)) 152 . . S XUSNP(12)=$P(DIC4,U) 153 . . S XUSNP(13)=$P(DIC4,U,2) 154 . . S XUSNP(14)=$P(DIC4,U,3) 155 . . S XUSNP(15)=$P(DIC4,U,4) 156 . . I XUSNP(15) S XUSNP(15)=$P($G(^DIC(5,XUSNP(15),0)),U,2) 157 . . S XUSNP(16)=$P(DIC4,U,5) 158 . . S XUSSTA(XUSDIV)=$P($G(^DIC(4,XUSDIV,99)),U) 159 . . S SPADR(XUSDIV)=XUSNP(12)_U_XUSNP(13)_U_XUSNP(14)_U_XUSNP(15)_U_XUSNP(16) 160 . ; If no divisions found 161 . I '$D(SPADR) D 162 . . S XUSSTA(9999)="N/A",SPADR(9999)=XUSNP(12)_U_XUSNP(13)_U_XUSNP(14)_U_XUSNP(15)_U_XUSNP(16) 163 . ; 164 . ; Office Phone number 165 . S XUSOPN=$P($G(^VA(200,NPIEN,.13)),U,2) 166 . I XUSOPN'="" S XUSNP(17)=XUSOPN 167 . ; 168 . ; Degree 169 . S XUSNP(18)=$P($G(^VA(200,NPIEN,3.1)),U,6) 170 . ; Degree Code (place holder) 171 . S XUSNP(19)="" 172 . ; 173 . ; get taxonomy and specialty 174 . S XUSPER=0 175 . F S XUSPER=$O(^VA(200,NPIEN,"USC1","B",XUSPER)) Q:'XUSPER D 176 . . S XUSSPC=$P($G(^USC(8932.1,XUSPER,0)),U,9) 177 . . S XUSTAX=$P($G(^USC(8932.1,XUSPER,0)),U,7) 178 . . I XUSSPC'="" D 179 . . . I XUSNP(20)="" S XUSNP(20)=XUSSPC Q 180 . . . S XUSNP(20)=XUSNP(20)_";"_XUSSPC 181 . . I XUSTAX'="" D 182 . . . I XUSNP(21)="" S XUSNP(21)=XUSTAX Q 183 . . . S XUSNP(21)=XUSNP(21)_";"_XUSTAX 184 . ; 185 . ; Tax ID 186 . S XUSTAXID=$P($G(^VA(200,NPIEN,"TPB")),U,2) 187 . I XUSTAXID="" S XUSTAXID=$P($G(^VA(200,NPIEN,1)),U,9) 188 . S XUSNP(22)=XUSTAXID 189 . ; 190 . S XUSDATA2=XUSNP(17)_U_XUSNP(18)_U_XUSNP(19)_U_XUSNP(20)_U_XUSNP(21)_U_XUSNP(22) 191 . ; 192 . ; Medicare Part A/B 193 . S XUSNP(23)=670899 194 . S XUSNP(24)="VA"_$E(SITE+10000,2,5) 195 . ; 196 . ; State License 197 . S XUSSTL=0 198 . F S XUSSTL=$O(^VA(200,NPIEN,"PS1",XUSSTL)) Q:'XUSSTL D 199 . . S XUSSTLN=$P($G(^VA(200,NPIEN,"PS1",XUSSTL,0)),U,2) 200 . . I XUSSTLN'="" D 201 . . . I XUSNP(25)="" S XUSNP(25)=XUSSTLN Q 202 . . . S XUSNP(25)=XUSNP(25)_";"_XUSSTLN 203 . ; DEA # 204 . S XUSNP(26)=$P($G(^VA(200,NPIEN,"PS")),U,2) 205 . ; 206 . S XUSDATA2=XUSDATA2_U_XUSNP(23)_U_XUSNP(24)_U_XUSNP(25)_U_XUSNP(26) 207 . ; 208 . ; Station # 209 . S XUSNP(27)="" 210 . ; 211 . ; Get BCBS Payer ID Array 212 . K XUSBXID 213 . D PRACID^XUSNPIXU(NPIEN,.XUSBXID) 214 . ; 215 . ; Save entry to ^TMP and update count 216 . N XUSB 217 . S XUSDIV=0 218 . F S XUSDIV=$O(SPADR(XUSDIV)) Q:'XUSDIV D 219 . . S COUNT=COUNT+1,TOTREC=TOTREC+1 220 . . S ^TMP(XUSRTN,$J,COUNT)=XUSDATA1_U_SPADR(XUSDIV)_U_XUSDATA2_U_XUSSTA(XUSDIV)_U_XUSEOL 221 . . S XUSIZE=XUSIZE+$L(^TMP(XUSRTN,$J,COUNT)) 222 . . ; Check BCBS Id array 223 . . I $D(XUSBXID) D 224 . . . S XUSB="" 225 . . . F S XUSB=$O(XUSBXID(XUSB)) Q:XUSB="" D 226 . . . . S COUNT=COUNT+1,TOTREC=TOTREC+1 227 . . . . S ^TMP(XUSRTN,$J,COUNT)=XUSDATA1_U_SPADR(XUSDIV)_U_XUSDATA2_U_XUSSTA(XUSDIV)_U_XUSB_U_XUSEOL 228 . . . . S XUSIZE=XUSIZE+$L(^TMP(XUSRTN,$J,COUNT)) 229 . K XUSNP,XUSDATA1,XUSDATA2,XUSDATA3,SPADR,XUSBXID,CNT,XUSSTA 230 . I XUSIZE>MAXSIZE D 231 . . D EOF(XUSRTN) 232 . . D EMAIL^XUSNPIX5(XUSRTN) 233 . . D VMAIL^XUSNPIX5(XUSRTN) 234 . . S ^TMP(XUSRTN,$J,1)=XUSHDR 235 . . S COUNT=1,XUSIZE=0 236 D EOF(XUSRTN) 237 ; set summary totals 238 S ^XTMP("XUSNPIXT",0)=(DT+10000)_U_DT_U_"NPI EXTRACT SUMMARY TOTALS"_U_DT_U_$H 239 S ^XTMP("XUSNPIXT","H")=$P(XUSHDR,U,1,4) 240 S ^XTMP("XUSNPIXT",1)=MSGCNT_U_TOTREC_U_DTTM 241 K INSMAIL,SITE 242 Q 243 ; 244 EOF(XUSRTN) ; 245 S MSGCNT=MSGCNT+1 246 S ^TMP(XUSRTN,$J,1)=XUSHDR_U_"Message Number: "_MSGCNT_U_"Line Count: "_COUNT_U_DTTM_U_$G(XUSPROD)_U_XUSEOL 247 S COUNT=COUNT+1 248 S ^TMP(XUSRTN,$J,COUNT)="END OF FILE"_U_XUSEOL 249 Q -
WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPIX2.m
r613 r623 1 XUSNPIX2 ;OAK_BP/CMW - NPI EXTRACT REPORT ;7/7/08 17:17 2 ;;8.0;KERNEL;**438,452,453,481**; Jul 10, 1995;Build 21 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 ; NPI Extract Report 6 ; 7 ; Input parameter: N/A 8 ; 9 ; Other relevant variables: 10 ; XUSRTN="XUSNPIX2" (current routine name, used for ^XTMP and ^TMP 11 ; storage subscript) 12 ; Storage Global: 13 ; ^XTMP("XUSNPIX2",0) = Piece 1^Piece 2^Piece 3^Piece 4^Piece 5^Piece 6 14 ; where: 15 ; Piece 1 => Purge Date - 1 year in future 16 ; Piece 2 => Create Date - Today 17 ; Piece 3 => Description 18 ; Piece 4 => Last Date Compiled 19 ; Piece 5 => $H last run start time 20 ; Piece 6 => $H last run completion time 21 ; 22 ; ^XTMP("XUSNPIX2",1) = STATION INFO 23 ; ^XTMP("XUSNPIX2",2) = DATA 24 ; 25 ; NPI => Unique NPI of entry 26 ; LDT => Last Date Run, VA Fileman Format 27 ; 28 ; Entry Point - ENT called from XUSNPIX1 29 ; 30 Q 31 ; 32 ENT(XUSPROD,XUSVER) ; ENTRY POINT 33 ; Initialize variables 34 N XUSRTN 35 S XUSRTN="XUSNPIX2" 36 S DTTM2=$$HTE^XLFDT($H,"2") 37 ; Check to see if report is in use 38 L +^XTMP(XUSRTN):5 I '$T G EXIT 39 ; Process Institution File 40 D INIT(XUSRTN) 41 ; Pull Station(Institution) data 42 D STAT(XUSRTN) 43 ; Process Report 44 D PROC2(XUSRTN,XUSPROD,DTTM2) 45 ; 46 ; Standard EXIT point 47 EXIT ; 48 K ^TMP(XUSRTN,$J),^TMP($J,"XUS59"),^TMP("XUSNPIX",$J) 49 ; Log Run Completion Time 50 S $P(^XTMP(XUSRTN,0),U,6)=$H 51 L -^XTMP(XUSRTN) 52 K P,XUSPT,INST,DTTM2,XUSIZE,XUSHDR,XUSTAXID 53 Q 54 ; 55 INIT(XUSRTN) ; check/init variables 56 N XUSDESC 57 ; 58 ; Reset Temporary Scratch Global 59 K ^TMP(XUSRTN) 60 S XUSDESC="NPI EXTRACT TYPE 2 - Do Not Delete" 61 S ^XTMP(XUSRTN,0)=(DT+10000)_U_DT_U_XUSDESC_U_DT_U_$H 62 ; 63 I '$D(^TMP("XUSNPIXU",$J)) D BCBSID^XUSNPIXU 64 ; 65 ; Create pharmacy institution ^TMP file 66 D GETPHARM 67 Q 68 ; 69 STAT(XUSRTN) ; Pull station and Institution info 70 N SINFO,DIC4,IBSITE,IBFAC,IB0 71 ; Pull site info 72 S SINFO=$$SITE^VASITE 73 ; Station Number 74 S SITE=$P(SINFO,U,3) 75 ; Institution 76 S INST=$P(SINFO,U) 77 ; 78 ; Get Federal Tax Id 79 S XUSTAXID="" 80 S IBSITE=0 81 F S IBSITE=$O(^IBE(350.9,IBSITE)) Q:'IBSITE!(XUSTAXID'="") D 82 . S XUSTAXID=$P($G(^IBE(350.9,IBSITE,1)),U,5) 83 ; 84 ; Get institution mailing address (PAY TO) 85 ;ST ADDR 1,ST ADDR 2,CITY,ZIP 86 I INST D 87 . S DIC4=$G(^DIC(4,INST,4)) 88 . S XUSPT(4)=$P(DIC4,U) 89 . S XUSPT(5)=$P(DIC4,U,2) 90 . S XUSPT(6)=$P(DIC4,U,3) 91 . S XUSPT(7)=$P(DIC4,U,4) 92 . I XUSPT(7) S XUSPT(7)=$P($G(^DIC(5,XUSPT(7),0)),U,2) 93 . S XUSPT(8)=$P(DIC4,U,5) 94 . S PTPMAIL=XUSPT(4)_U_XUSPT(5)_U_XUSPT(6)_U_XUSPT(7)_U_XUSPT(8) 95 S XUSHDR="Station: "_SITE_U_XUSPT(6)_U_XUSPT(7)_U_XUSPT(8)_U_"TYPE 2"_U_XUSVER 96 ; 97 Q 98 ; 99 PROC2(XUSRTN,XUSPROD,DTTM2) ;Process all Institution records 100 N XUSNPI,XUSNEW,XUSDT,XUSI,XUSIN,XUSTXY,XUSSPC,XUSTAX,XUPHM 101 N XUSFCT,XUSFCN,XUSDATA1,XUSDATA2,XUSDATA3,XUSDATA4,XUSDATA5,XUSSTA,XUSEOL 102 N INIEN,DIC0,DIC1,PSIEN,NPIINS,RELINS,PSSTA,COUNT,TOTREC,MSGCNT,MAXSIZE 103 ; 104 ; Set to 300000 for live 105 S MAXSIZE=300000 106 ; 107 ; Set end of line character 108 S XUSEOL="~~" 109 ; 110 ; set counter 111 S COUNT=1,(TOTREC,MSGCNT,XUSIZE)=0 112 ; Loop through INSTITUTION NPI records NPI xref 113 S XUSNPI=0 114 F S XUSNPI=$O(^DIC(4,"ANPI",XUSNPI)) Q:'XUSNPI D 115 . S INIEN=$O(^DIC(4,"ANPI",XUSNPI,"")) 116 . ; 117 . ; Get Station Number 118 . S XUSSTA=$P($G(^DIC(4,INIEN,99)),U) 119 . ; Parent of Association 120 . I (INIEN'=INST)&('$$POA(INIEN,INST)) Q 121 . ; Initialize columns 122 . F XUSI=1:1:24 S XUSIN(XUSI)="" 123 . ; 124 . S XUSIN(1)=XUSNPI 125 . S DIC0=$G(^DIC(4,INIEN,0)) Q:DIC0="" 126 . ;Organization Name 127 . S XUSIN(2)=$P($G(DIC0),U) 128 . S XUSIN(3)=2 129 . S XUSDATA1=XUSIN(1)_U_XUSIN(2)_U_XUSIN(3) 130 . ; 131 . ; Pay to Provider Address 132 . S XUSDATA2=PTPMAIL 133 . ; 134 . ; Servicing Provider Address 135 . S DIC1=$G(^DIC(4,INIEN,1)) 136 . I DIC1'="" D 137 . . S XUSIN(9)=$P(DIC1,U) 138 . . S XUSIN(10)=$P(DIC1,U,2) 139 . . S XUSIN(11)=$P(DIC1,U,3) 140 . . S XUSIN(12)=$P($G(DIC0),U,2) 141 . . I XUSIN(12) S XUSIN(12)=$P($G(^DIC(5,XUSIN(12),0)),U,2) 142 . . S XUSIN(13)=$P(DIC1,U,4) 143 . S XUSDATA3=XUSIN(9)_U_XUSIN(10)_U_XUSIN(11)_U_XUSIN(12)_U_XUSIN(13) 144 . ; 145 . ;Phone number (place holder) 146 . S XUSIN(14)="" 147 . ; 148 . ; Get Taxonomy and Specialty 149 . S XUSTXY=0 150 . F S XUSTXY=$O(^DIC(4,INIEN,"TAXONOMY","B",XUSTXY)) Q:'XUSTXY D 151 . . S XUSSPC=$P($G(^USC(8932.1,XUSTXY,0)),U,9) 152 . . S XUSTAX=$P($G(^USC(8932.1,XUSTXY,0)),U,7) 153 . . I XUSSPC'="" D 154 . . . I XUSIN(15)="" S XUSIN(15)=XUSSPC Q 155 . . . S XUSIN(15)=XUSIN(15)_";"_XUSSPC 156 . . I XUSTAX'="" D 157 . . . I XUSIN(16)="" S XUSIN(16)=XUSTAX Q 158 . . . S XUSIN(16)=XUSIN(16)_";"_XUSTAX 159 . ; 160 . ; Federal Tax ID 161 . S XUSIN(17)=$G(XUSTAXID) 162 . ; 163 . ; Medicaid Part A/B 164 . S XUSIN(18)=670899 165 . S XUSIN(19)="VA"_$E(SITE+10000,2,5) 166 . ; 167 . S XUSDATA4=XUSIN(14)_U_XUSIN(15)_U_XUSIN(16)_U_XUSIN(17)_U_XUSIN(18)_U_XUSIN(19) 168 . ; 169 . ; DEA Number 170 . S XUSIN(20)=$P($G(^DIC(4,INIEN,"DEA")),U) 171 . ; 172 . ; get Facility Type and Name 173 . S XUSFCT=$P($G(^DIC(4,INIEN,3)),U) 174 . I XUSFCT'="" S XUSFCN=$P($G(^DIC(4.1,XUSFCT,0)),U) 175 . I $G(XUSFCN)="PHARM" D 176 . . I $D(^TMP("XUSNPIX",$J,INIEN)) D 177 . . . S XUPHM=^TMP("XUSNPIX",$J,INIEN) 178 . . . ; get NCPDP from ^TMP 179 . . . S XUSIN(21)=$P($G(XUPHM),U) 180 . . . ; get station number from^TMP 181 . . . I $P($G(XUPHM),U,2) S XUSSTA=$P(XUPHM,U,2) 182 . ; 183 . ; VISN Station Number 184 . S XUSIN(22)=XUSSTA 185 . ; 186 . S XUSDATA5=XUSIN(20)_U_XUSIN(21)_U_XUSIN(22) 187 . ; 188 . ; Get BCBS Payer ID Array 189 . K XUSBXID 190 . D INSTID^XUSNPIXU(.XUSBXID) 191 . ; 192 . ; Update counter and save Entry 193 . ; 194 . S COUNT=COUNT+1,TOTREC=TOTREC+1 195 . S ^TMP(XUSRTN,$J,COUNT)=XUSDATA1_U_XUSDATA2_U_XUSDATA3_U_XUSDATA4_U_XUSDATA5_U_XUSEOL 196 . S XUSIZE=XUSIZE+$L(^TMP(XUSRTN,$J,COUNT)) 197 . I $D(XUSBXID) D 198 . . S XUSB="" 199 . . F S XUSB=$O(XUSBXID(XUSB)) Q:XUSB="" D 200 . . . S COUNT=COUNT+1,TOTREC=TOTREC+1 201 . . . S ^TMP(XUSRTN,$J,COUNT)=XUSDATA1_U_XUSDATA2_U_XUSDATA3_U_XUSDATA4_U_XUSDATA5_U_XUSB_U_XUSBXID(XUSB)_U_XUSEOL 202 . . . S XUSIZE=XUSIZE+$L(^TMP(XUSRTN,$J,COUNT)) 203 . K XUSIN,XUSDATA1,XUSDATA2,XUSDATA3,XUSDATA4,XUSDATA5,XUSB,XUSBXID 204 . I XUSIZE>MAXSIZE D 205 . . D EOF(XUSRTN) 206 . . D EMAIL(XUSRTN) 207 . . K ^TMP(XUSRTN,$J) 208 . . S ^TMP("XUSNPIXS",$J,2,MSGCNT)="2^"_(COUNT-2) 209 . . S ^TMP(XUSRTN,$J,1)=XUSHDR 210 . . S COUNT=1,XUSIZE=0 211 ; 212 D EOF(XUSRTN) 213 ; 214 ; Send the last message (if it has records) 215 I $G(COUNT)>1 D 216 .D EMAIL(XUSRTN) 217 .K ^TMP(XUSRTN,$J) 218 .S ^TMP("XUSNPIXS",$J,2,MSGCNT)="2^"_(COUNT-2) 219 ; 220 ; Set Summary totals 221 S ^XTMP("XUSNPIXT",2)=MSGCNT_U_TOTREC_U_DTTM2 222 ; 223 K XUSPT,PTPMAIL,LDTCMP,SITE,XUSTAXID 224 Q 225 ; 226 EOF(XUSRTN) ; 227 Q:COUNT=1 228 S MSGCNT=MSGCNT+1 229 S ^TMP(XUSRTN,$J,1)=XUSHDR_U_"Message Number: "_MSGCNT_U_"Line Count: "_COUNT_U_DTTM2_U_$G(XUSPROD)_U_XUSEOL 230 S COUNT=COUNT+1 231 S ^TMP(XUSRTN,$J,COUNT)="END OF FILE"_U_XUSEOL 232 Q 233 ; 234 ; Email the message 235 EMAIL(XUSRTN) ; 236 N XMY 237 ; Send email to designated recipient for live release 238 S XMY("XXX@Q-NPS.VA.GOV")="" 239 D ESEND 240 Q 241 ; 242 ESEND N XMTEXT,XMSUB,XMDUN,XMDUZ,XMZ,XMMG,DIFROM 243 ; 244 S XMTEXT="^TMP("""_XUSRTN_""","_$J_"," 245 S XMSUB=$TR($P($G(^TMP(XUSRTN,$J,1)),U),":")_"("_$G(XUSPROD)_") NPI EXTRACT TYPE 2" 246 D ^XMD 247 Q 248 POA(IEN,INST) ; Check Parent of Association for Institution IEN up to VISN level to see if INST is in the chain 249 N XUSPOA 250 I +$G(INST)=0 Q 0 ; No institution - return false 251 POA1 ; 252 I $G(IEN)="" Q 0 ; No IEN remaining to check - return false 253 I $D(XUSPOA(IEN)) Q 0 ; Already reviewed this IEN - possible infinite loop - return false 254 S XUSPOA(IEN)="" 255 S XUSPOA=$P($G(^DIC(4,IEN,7,2,0)),U,2) ; Get parent of this institution 256 I XUSPOA=INST Q 1 ; Found matching institution - return true 257 I IEN=XUSPOA Q 0 ; Top level reached - return false 258 S IEN=XUSPOA ; Reset IEN to check next level 259 G POA1 260 ; 261 GETPHARM ; 262 ; this subroutine retrieves data from the OUTPATIENT SITE file 263 ; using the supported Pharmacy API PSS^PSO59. 264 ; It takes the results and places them into a temporary 265 ; global array that is accessed when processing data 266 ; associated with a pharmacy institution. 267 N D,DIC,XUS59DA,XUSNPIDA,XUSRELDA,PSSTA,Y,X,XUNCP 268 ; 269 ;Fix for Remedy Ticket 217164 270 ;Quit if Outpatient Site API routine is not loaded 271 S X="PSO59" X ^%ZOSF("TEST") Q:'$T 272 ; 273 K ^TMP($J,"XUS59"),^TMP("XUSNPIX",$J) ; remove any pre-existing nodes 274 D PSS^PSO59(,"??","XUS59") ;IA#4827 275 S XUS59DA=0 276 ; gather data from each Outpatient site entry stored in the pharmacy 277 ; ^TMP global and build 2nd ^TMP global for later processing 278 F S XUS59DA=$O(^TMP($J,"XUS59",XUS59DA)) Q:'XUS59DA D 279 . ; 280 . ;Get Pharmacy NPI institution from API 281 . S XUSNPIDA=$P($G(^TMP($J,"XUS59",XUS59DA,101)),U) 282 . Q:XUSNPIDA']"" ; NPI institution does not exist 283 . ; 284 . ; Get Pharmacy Related Institution from API 285 . S XUSRELDA=$P($G(^TMP($J,"XUS59",XUS59DA,100)),U) 286 . ; get station number off the related institution 287 . S PSSTA=$P($G(^DIC(4,XUSRELDA,99)),U) 288 . ; 289 . ; Get NCPDP number 290 . S XUNCP="" ;prevent previous values being carried over 291 . S X=XUSNPIDA S D="C",DIC=9002313.56,DIC(0)="" D IX^DIC 292 . I +Y>0 S XUNCP=$$GET1^DIQ(9002313.56,+Y,.02) 293 . S:$G(XUNCP)="" XUNCP=$P($G(^TMP($J,"XUS59",XUS59DA,1008)),U) 294 . ; 295 . ; rebuild the ^TMP global by NPI institution 296 . ; collect necessary data used in the 'PHARM' logic 297 . S ^TMP("XUSNPIX",$J,XUSNPIDA)=XUNCP_"^"_PSSTA ; ncpdp#^station 298 Q 1 XUSNPIX2 ;OAK_BP/CMW - NPI EXTRACT REPORT ; 06 Sep 2007 3:34 PM 2 ;;8.0;KERNEL;**438,452,453**; Jul 10, 1995;Build 36 3 ;;Per VHA Directive 10-93-142, this routine should not be modified. 4 ; 5 ; NPI Extract Report 6 ; 7 ; Input parameter: N/A 8 ; 9 ; Other relevant variables: 10 ; XUSRTN="XUSNPIX2" (current routine name, used for ^XTMP and ^TMP 11 ; storage subscript) 12 ; Storage Global: 13 ; ^XTMP("XUSNPIX2",0) = Piece 1^Piece 2^Piece 3^Piece 4^Piece 5^Piece 6 14 ; where: 15 ; Piece 1 => Purge Date - 1 year in future 16 ; Piece 2 => Create Date - Today 17 ; Piece 3 => Description 18 ; Piece 4 => Last Date Compiled 19 ; Piece 5 => $H last run start time 20 ; Piece 6 => $H last run completion time 21 ; 22 ; ^XTMP("XUSNPIX2",1) = STATION INFO 23 ; ^XTMP("XUSNPIX2",2) = DATA 24 ; 25 ; NPI => Unique NPI of entry 26 ; LDT => Last Date Run, VA Fileman Format 27 ; 28 ; Entry Point - ENT called from XUSNPIX1 29 ; 30 Q 31 ; 32 ENT ; ENTRY POINT 33 ; Initialize variables 34 N XUSRTN 35 S XUSRTN="XUSNPIX2" 36 S DTTM2=$$HTE^XLFDT($H,"2") 37 ; Check to see if report is in use 38 L +^XTMP(XUSRTN):5 I '$T G EXIT 39 ; Process Institution File 40 D INIT(XUSRTN) 41 ; Pull Station(Institution) data 42 D STAT(XUSRTN) 43 ; Process Report 44 D PROC2(XUSRTN) 45 ; Send the message 46 D EMAIL(XUSRTN) 47 D VMAIL(XUSRTN) 48 S ^XTMP("XUSNPIXT",2)=MSGCNT_U_TOTREC_U_DTTM2 49 ; 50 ; Standard EXIT point 51 EXIT ; 52 K ^TMP(XUSRTN,$J),^TMP($J,"XUS59"),^TMP("XUSNPIX",$J) 53 ; Log Run Completion Time 54 S $P(^XTMP(XUSRTN,0),U,6)=$H 55 L -^XTMP(XUSRTN) 56 K P,XUSPT,INST,XUSEOL,DTTM2,MAXSIZE,XUSIZE,MSGCNT,COUNT,TOTREC,XUSHDR,XUSTAXID 57 Q 58 ; 59 ; 60 INIT(XUSRTN) ; check/init variables 61 N XUSDESC 62 ; Set end of line character 63 S XUSEOL="~~" 64 ; Set to 300000 for live 65 S MAXSIZE=300000 66 ; Reset Temporary Scratch Global 67 K ^TMP(XUSRTN) 68 S XUSDESC="NPI EXTRACT TYPE 2 - Do Not Delete" 69 S ^XTMP(XUSRTN,0)=(DT+10000)_U_DT_U_XUSDESC_U_DT_U_$H 70 ; 71 I '$D(^TMP("XUSNPIXU",$J)) D BCBSID^XUSNPIXU 72 ; 73 ; Create pharmacy institution ^TMP file 74 D GETPHARM 75 Q 76 ; 77 STAT(XUSRTN) ; Pull station and Institution info 78 N SINFO,DIC4,IBSITE,IBFAC,IB0 79 ; Pull site info 80 S SINFO=$$SITE^VASITE 81 ; Station Number 82 S SITE=$P(SINFO,U,3) 83 ; Institution 84 S INST=$P(SINFO,U) 85 ; 86 ; Get Federal Tax Id 87 S XUSTAXID="" 88 S IBSITE=0 89 F S IBSITE=$O(^IBE(350.9,IBSITE)) Q:'IBSITE!(XUSTAXID'="") D 90 . S XUSTAXID=$P($G(^IBE(350.9,IBSITE,1)),U,5) 91 ; 92 ; Get institution mailing address (PAY TO) 93 ;ST ADDR 1,ST ADDR 2,CITY,ZIP 94 I INST D 95 . S DIC4=$G(^DIC(4,INST,4)) 96 . S XUSPT(4)=$P(DIC4,U) 97 . S XUSPT(5)=$P(DIC4,U,2) 98 . S XUSPT(6)=$P(DIC4,U,3) 99 . S XUSPT(7)=$P(DIC4,U,4) 100 . I XUSPT(7) S XUSPT(7)=$P($G(^DIC(5,XUSPT(7),0)),U,2) 101 . S XUSPT(8)=$P(DIC4,U,5) 102 . S PTPMAIL=XUSPT(4)_U_XUSPT(5)_U_XUSPT(6)_U_XUSPT(7)_U_XUSPT(8) 103 S XUSHDR="Station: "_SITE_U_XUSPT(6)_U_XUSPT(7)_U_XUSPT(8)_U_"TYPE 2"_U_XUSVER 104 ; 105 Q 106 ; 107 PROC2(XUSRTN) ;Process all Institution records 108 N XUSNPI,XUSNEW,XUSDT,XUSI,XUSIN,XUSTXY,XUSSPC,XUSTAX,XUPHM 109 N XUSFCT,XUSFCN,XUSDATA1,XUSDATA2,XUSDATA3,XUSDATA4,XUSDATA5,XUSSTA 110 N INIEN,DIC0,DIC1,PSIEN,NPIINS,RELINS,PSSTA 111 ; set counter 112 S COUNT=1,(TOTREC,MSGCNT,XUSIZE)=0 113 ; Loop through INSTITUTION NPI records NPI xref 114 S XUSNPI=0 115 F S XUSNPI=$O(^DIC(4,"ANPI",XUSNPI)) Q:'XUSNPI D 116 . S INIEN=$O(^DIC(4,"ANPI",XUSNPI,"")) 117 . ; 118 . ; Get Station Number 119 . S XUSSTA=$P($G(^DIC(4,INIEN,99)),U) 120 . ; Parent of Association 121 . I (INIEN'=INST)&('$$POA(INIEN,INST)) Q 122 . ; Initialize columns 123 . F XUSI=1:1:24 S XUSIN(XUSI)="" 124 . ; 125 . S XUSIN(1)=XUSNPI 126 . S DIC0=$G(^DIC(4,INIEN,0)) Q:DIC0="" 127 . ;Organization Name 128 . S XUSIN(2)=$P($G(DIC0),U) 129 . S XUSIN(3)=2 130 . S XUSDATA1=XUSIN(1)_U_XUSIN(2)_U_XUSIN(3) 131 . ; 132 . ; Pay to Provider Address 133 . S XUSDATA2=PTPMAIL 134 . ; 135 . ; Servicing Provider Address 136 . S DIC1=$G(^DIC(4,INIEN,1)) 137 . I DIC1'="" D 138 . . S XUSIN(9)=$P(DIC1,U) 139 . . S XUSIN(10)=$P(DIC1,U,2) 140 . . S XUSIN(11)=$P(DIC1,U,3) 141 . . S XUSIN(12)=$P($G(DIC0),U,2) 142 . . I XUSIN(12) S XUSIN(12)=$P($G(^DIC(5,XUSIN(12),0)),U,2) 143 . . S XUSIN(13)=$P(DIC1,U,4) 144 . S XUSDATA3=XUSIN(9)_U_XUSIN(10)_U_XUSIN(11)_U_XUSIN(12)_U_XUSIN(13) 145 . ; 146 . ;Phone number (place holder) 147 . S XUSIN(14)="" 148 . ; 149 . ; Get Taxonomy and Specialty 150 . S XUSTXY=0 151 . F S XUSTXY=$O(^DIC(4,INIEN,"TAXONOMY","B",XUSTXY)) Q:'XUSTXY D 152 . . S XUSSPC=$P($G(^USC(8932.1,XUSTXY,0)),U,9) 153 . . S XUSTAX=$P($G(^USC(8932.1,XUSTXY,0)),U,7) 154 . . I XUSSPC'="" D 155 . . . I XUSIN(15)="" S XUSIN(15)=XUSSPC Q 156 . . . S XUSIN(15)=XUSIN(15)_";"_XUSSPC 157 . . I XUSTAX'="" D 158 . . . I XUSIN(16)="" S XUSIN(16)=XUSTAX Q 159 . . . S XUSIN(16)=XUSIN(16)_";"_XUSTAX 160 . ; 161 . ; Federal Tax ID 162 . S XUSIN(17)=$G(XUSTAXID) 163 . ; 164 . ; Medicaid Part A/B 165 . S XUSIN(18)=670899 166 . S XUSIN(19)="VA"_$E(SITE+10000,2,5) 167 . ; 168 . S XUSDATA4=XUSIN(14)_U_XUSIN(15)_U_XUSIN(16)_U_XUSIN(17)_U_XUSIN(18)_U_XUSIN(19) 169 . ; 170 . ; DEA Number 171 . S XUSIN(20)=$P($G(^DIC(4,INIEN,"DEA")),U) 172 . ; 173 . ; get Facility Type and Name 174 . S XUSFCT=$P($G(^DIC(4,INIEN,3)),U) 175 . I XUSFCT'="" S XUSFCN=$P($G(^DIC(4.1,XUSFCT,0)),U) 176 . I $G(XUSFCN)="PHARM" D 177 . . I $D(^TMP("XUSNPIX",$J,INIEN)) D 178 . . . S XUPHM=^TMP("XUSNPIX",$J,INIEN) 179 . . . ; get NCPDP from ^TMP 180 . . . S XUSIN(21)=$P($G(XUPHM),U) 181 . . . ; get station number from^TMP 182 . . . I $P($G(XUPHM),U,2) S XUSSTA=$P(XUPHM,U,2) 183 . ; 184 . ; VISN Station Number 185 . S XUSIN(22)=XUSSTA 186 . ; 187 . S XUSDATA5=XUSIN(20)_U_XUSIN(21)_U_XUSIN(22) 188 . ; 189 . ; Get BCBS Payer ID Array 190 . K XUSBXID 191 . D INSTID^XUSNPIXU(.XUSBXID) 192 . ; 193 . ; Update counter and save Entry 194 . ; 195 . S COUNT=COUNT+1,TOTREC=TOTREC+1 196 . S ^TMP(XUSRTN,$J,COUNT)=XUSDATA1_U_XUSDATA2_U_XUSDATA3_U_XUSDATA4_U_XUSDATA5_U_XUSEOL 197 . S XUSIZE=XUSIZE+$L(^TMP(XUSRTN,$J,COUNT)) 198 . I $D(XUSBXID) D 199 . . S XUSB="" 200 . . F S XUSB=$O(XUSBXID(XUSB)) Q:XUSB="" D 201 . . . S COUNT=COUNT+1,TOTREC=TOTREC+1 202 . . . S ^TMP(XUSRTN,$J,COUNT)=XUSDATA1_U_XUSDATA2_U_XUSDATA3_U_XUSDATA4_U_XUSDATA5_U_XUSB_U_XUSBXID(XUSB)_U_XUSEOL 203 . . . S XUSIZE=XUSIZE+$L(^TMP(XUSRTN,$J,COUNT)) 204 . K XUSIN,XUSDATA1,XUSDATA2,XUSDATA3,XUSDATA4,XUSDATA5,XUSB,XUSBXID 205 . I XUSIZE>MAXSIZE D 206 . . D EOF(XUSRTN) 207 . . D EMAIL(XUSRTN) 208 . . D VMAIL(XUSRTN) 209 . . S ^TMP(XUSRTN,$J,1)=XUSHDR 210 . . S COUNT=1,XUSIZE=0 211 ; 212 D EOF(XUSRTN) 213 K XUSPT,PTPMAIL,LDTCMP,SITE,XUSTAXID 214 Q 215 ; 216 EOF(XUSRTN) ; 217 S MSGCNT=MSGCNT+1 218 S ^TMP(XUSRTN,$J,1)=XUSHDR_U_"Message Number: "_MSGCNT_U_"Line Count: "_COUNT_U_DTTM2_U_$G(XUSPROD)_U_XUSEOL 219 S COUNT=COUNT+1 220 S ^TMP(XUSRTN,$J,COUNT)="END OF FILE"_U_XUSEOL 221 Q 222 ; 223 ; EMail the message 224 EMAIL(XUSRTN) ; 225 N XMY 226 ; Send email to designated recipient for live release 227 S XMY("XXX@Q-NPS.VA.GOV")="" 228 ;S XMY(DUZ)="" ;use for testing - remove before live 229 D ESEND 230 Q 231 ; 232 VMAIL(XUSRTN) ; verification email 233 N TMP 234 S TMP=^TMP(XUSRTN,$J,1) 235 K ^TMP(XUSRTN,$J) 236 S ^TMP(XUSRTN,$J,1)=$P(TMP,U,1,4) 237 S ^TMP(XUSRTN,$J,2)="" 238 S ^TMP(XUSRTN,$J,3)="TYPE 1 : INSTITUTION FILE (#4)" 239 S ^TMP(XUSRTN,$J,4)="" 240 S ^TMP(XUSRTN,$J,5)="Date/Time of Extract: "_$P(TMP,U,9) 241 S ^TMP(XUSRTN,$J,6)="" 242 S ^TMP(XUSRTN,$J,7)="Message number: "_MSGCNT_" Total NPI records: "_(COUNT-2) 243 S ^TMP(XUSRTN,$J,8)="" 244 S ^TMP(XUSRTN,$J,9)="Programmer Notes: "_XUSVER_" - "_$P(TMP,U,10) 245 ; Send verification email to local mail group and VA Outlook mail group 246 S XMY("G.NPI EXTRACT VERIFICATION")="" 247 D ESEND 248 K ^TMP(XUSRTN) 249 Q 250 ESEND N XMTEXT,XMSUB,XMDUN,XMDUZ,XMZ 251 ;Q 252 S XMTEXT="^TMP("""_XUSRTN_""","_$J_"," 253 S XMSUB=$TR($P($G(^TMP(XUSRTN,$J,1)),U),":")_"("_$G(XUSPROD)_") NPI EXTRACT TYPE 2" 254 D ^XMD 255 Q 256 POA(IEN,INST) ; Check Parent of Association for Institution IEN up to VISN level to see if INST is in the chain 257 N XUSPOA 258 I +$G(INST)=0 Q 0 ; No institution - return false 259 POA1 ; 260 I $G(IEN)="" Q 0 ; No IEN remaining to check - return false 261 I $D(XUSPOA(IEN)) Q 0 ; Already reviewed this IEN - possible infinite loop - return false 262 S XUSPOA(IEN)="" 263 S XUSPOA=$P($G(^DIC(4,IEN,7,2,0)),U,2) ; Get parent of this institution 264 I XUSPOA=INST Q 1 ; Found matching institution - return true 265 I IEN=XUSPOA Q 0 ; Top level reached - return false 266 S IEN=XUSPOA ; Reset IEN to check next level 267 G POA1 268 ; 269 GETPHARM ; 270 ; this subroutine retrieves data from the OUTPATIENT SITE file 271 ; using the supported Pharmacy API PSS^PSO59. 272 ; It takes the results and places them into a temporary 273 ; global array that is accessed when processing data 274 ; associated with a pharmacy institution. 275 N XUS59DA,XUSNPIDA,XUSRELDA,PSSTA,Y,X,XUNCP 276 K ^TMP($J,"XUS59"),^TMP("XUSNPIX",$J) ; remove any pre-existing nodes 277 D PSS^PSO59(,"??","XUS59") 278 S XUS59DA=0 279 ; gather data from each Outpatient site entry stored in the pharmacy 280 ; ^TMP global and build 2nd ^TMP global for later processing 281 F S XUS59DA=$O(^TMP($J,"XUS59",XUS59DA)) Q:'XUS59DA D 282 . ; 283 . ;Get Pharmacy NPI institution from API 284 . S XUSNPIDA=$P($G(^TMP($J,"XUS59",XUS59DA,101)),U) 285 . Q:XUSNPIDA']"" ; NPI institution does not exist 286 . ; 287 . ; Get Pharmacy Related Institution from API 288 . S XUSRELDA=$P($G(^TMP($J,"XUS59",XUS59DA,100)),U) 289 . ; get station number off the related institution 290 . S PSSTA=$P($G(^DIC(4,XUSRELDA,99)),U) 291 . ; 292 . ; Get NCPDP number 293 . S XUNCP="" ;prevent previous values being carried over 294 . S X=XUSNPIDA S D="C",DIC=9002313.56,DIC(0)="" D IX^DIC 295 . I +Y>0 S XUNCP=$$GET1^DIQ(9002313.56,+Y,.02) 296 . S:$G(XUNCP)="" XUNCP=$P($G(^TMP($J,"XUS59",XUS59DA,1008)),U) 297 . ; 298 . ; rebuild the ^TMP global by NPI institution 299 . ; collect necessary data used in the 'PHARM' logic 300 . S ^TMP("XUSNPIX",$J,XUSNPIDA)=XUNCP_"^"_PSSTA ; ncpdp#^station 301 Q -
WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPIX3.m
r613 r623 1 XUSNPIX3 ;OAK_BP/CMW - NPI EXTRACT REPORT ;01-OCT-06 2 ;;8.0;KERNEL;**438,452,453,481**; Jul 10, 1995;Build 21 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 ; NPI Extract Report 6 ; 7 ; Input parameter: N/A 8 ; 9 ; Other relevant variables: 10 ; XUSRTN="XUSNPIX1NV" (current routine name, used for ^XTMP and ^TMP 11 ; XUSRTN="XUSNPIX2NV" storage subscript) 12 ; Storage Global: 13 ; ^XTMP("XUSNPIX1VA",0) = Piece 1^Piece 2^Piece 3^Piece 4^Piece 5^Piece 6 14 ; ^XTMP("XUSNPIX2VA",0) 15 ; where: 16 ; Piece 1 => Purge Date - 1 year in future 17 ; Piece 2 => Create Date - Today 18 ; Piece 3 => Description 19 ; Piece 4 => Last Date Compiled 20 ; Piece 5 => $H last run start time 21 ; Piece 6 => $H last run completion time 22 ; 23 ; Entry Point - ENT called from XUSNPIX1 24 ; 25 Q 26 ; 27 ENT(XUSPROD,XUSVER) ; ENTRY POINT 28 ; init variables 29 N XUSRTN,XUSEOL,DTTM3 30 N XUSNPI,XUSDATA,XUSTYP,XUST 31 N NVIEN,IBA0,PROTYPE,NPIDT,NPINEW 32 K ^TMP("XUSNPI",$J) 33 ; 34 ; Set end of line character 35 S XUSEOL="~~" 36 ; 37 S DTTM3=$$HTE^XLFDT($H,"2") 38 ; 39 S XUST="" 40 ; Loop through IB NON/OTHER VA BILLING PROVIDER records NPI xref 41 S XUSNPI=0 42 F S XUSNPI=$O(^IBA(355.93,"NPI",XUSNPI)) Q:'XUSNPI D 43 . S NVIEN=$O(^IBA(355.93,"NPI",XUSNPI,"")) 44 . S IBA0=$G(^IBA(355.93,NVIEN,0)) 45 . ; Get Provider Type 46 . S PROTYPE=$P(IBA0,U,2) 47 . S XUSTYP=$S(PROTYPE=1:2,1:1) 48 . ; setup NPI array 49 . S ^TMP("XUSNPI",$J,XUSTYP,XUSNPI)=NVIEN 50 . ; 51 ; If Provider Type is Individual 52 S XUSRTN="XUSNPIX1NV",NVHEADR=" NPI EXTRACT TYPE 1 (NON VA)",NVTYPE="TYPE 1 (NVA)" 53 I $D(^TMP("XUSNPI",$J,1)) D I XUST G EXIT 54 . ; Check to see if report is in use 55 . L +^XTMP(XUSRTN):5 I '$T S XUST=1 Q 56 . D INIT(XUSRTN) 57 . D INST(XUSRTN) 58 . D TYPE1^XUSNPIX4(DTTM3,PTPMAIL,SITE,XUSPROD,XUSHDR) 59 . ; 60 . ; Log Run Completion Time 61 . S $P(^XTMP(XUSRTN,0),U,6)=$H 62 . L -^XTMP(XUSRTN) 63 ; 64 I '$D(^TMP("XUSNPI",$J,1)) D 65 . D INIT(XUSRTN) 66 . D INST(XUSRTN) 67 . S ^TMP(XUSRTN,$J,1)=XUSHDR_U_"Message Number: "_1_U_"Line Count: "_1_U_DTTM3_U_$G(XUSPROD)_XUSEOL 68 . S ^XTMP("XUSNPIXT","1NV")=1_U_0_U_DTTM3 69 . S ^TMP(XUSRTN,$J,2)="END OF FILE"_U_XUSEOL 70 . D EMAIL(XUSRTN) 71 . S ^TMP("XUSNPIXS",$J,3,1)="1 (Non-VA)^0" 72 ; 73 ; If Provider Type is Facility/Group 74 S XUSRTN="XUSNPIX2NV",NVHEADR=" NPI EXTRACT TYPE 2 (NON VA)",NVTYPE="TYPE 2 (NVA)" 75 I $D(^TMP("XUSNPI",$J,2)) D I XUST G EXIT 76 . ; Check to see if report is in use 77 . L +^XTMP(XUSRTN):5 I '$T S XUST=1 Q 78 . D INIT(XUSRTN) 79 . D INST(XUSRTN) 80 . D TYPE2^XUSNPIX4(DTTM3,PTPMAIL,SITE,XUSPROD,XUSHDR) 81 . ; 82 . ; Log Run Completion Time 83 . S $P(^XTMP(XUSRTN,0),U,6)=$H 84 . L -^XTMP(XUSRTN) 85 . ; 86 I '$D(^TMP("XUSNPI",$J,2)) D 87 . D INIT(XUSRTN) 88 . D INST(XUSRTN) 89 . S ^TMP(XUSRTN,$J,1)=XUSHDR_U_"Message Number: "_1_U_"Line Count: "_1_U_DTTM3_U_$G(XUSPROD)_XUSEOL 90 . S ^XTMP("XUSNPIXT","2NV")=1_U_0_U_DTTM3 91 . S ^TMP(XUSRTN,$J,2)="END OF FILE"_U_XUSEOL 92 . D EMAIL(XUSRTN) 93 . S ^TMP("XUSNPIXS",$J,4,1)="2 (Non-VA)^0" 94 ; 95 EXIT ;Standard EXIT point 96 K ^TMP("XUSNPI",$J) 97 K XUSNV,P,LDTCMP,PTPMAIL,SITE,NVHEADR,NVTYPE,XUSEOL,DTTM3 98 K XUSHDR 99 ; 100 Q 101 ; 102 INIT(XUSRTN) ; check/init variables 103 N XUSDESC 104 ; 105 ;Reset Temporary Scratch Global 106 K ^TMP(XUSRTN) 107 S XUSDESC="NPI EXTRACT NON VA - Do Not Delete" 108 S ^XTMP(XUSRTN,0)=(DT+10000)_U_DT_U_XUSDESC_U_DT_U_$H 109 ; 110 I '$D(^TMP("XUSNPIXU",$J)) D BCBSID^XUSNPIXU 111 Q 112 ; 113 INST(XUSRTN) ;Pull station and Institution info 114 N INST,SINFO,DIC4 115 ; Pull site info 116 S SINFO=$$SITE^VASITE 117 ; Station Number 118 S SITE=$P(SINFO,U,3) 119 ; Institution 120 S INST=$P(SINFO,U) 121 ; 122 ; Get institution mailing address 123 I INST D 124 . S DIC4=$G(^DIC(4,INST,4)) 125 . S XUSNV(7)=$P(DIC4,U) 126 . S XUSNV(8)=$P(DIC4,U,2) 127 . S XUSNV(9)=$P(DIC4,U,3) 128 . S XUSNV(10)=$P(DIC4,U,4) 129 . I XUSNV(10) S XUSNV(10)=$P($G(^DIC(5,XUSNV(10),0)),U,2) 130 . S XUSNV(11)=$P(DIC4,U,5) 131 . S PTPMAIL=XUSNV(7)_U_XUSNV(8)_U_XUSNV(9)_U_XUSNV(10)_U_XUSNV(11) 132 S XUSHDR="Station: "_SITE_U_XUSNV(9)_U_XUSNV(10)_U_XUSNV(11)_U_NVTYPE_U_XUSVER 133 Q 134 ; 135 EMAIL(XUSRTN) ; EMAIL THE MESSAGE 136 N XMY 137 ; Send email to designated recipient for live release 138 S XMY("XXX@Q-NPS.VA.GOV")="" 139 D ESEND 140 Q 141 ; 142 ESEND N XMTEXT,XMSUB,XMDUN,XMDUZ,XMZ,XMMG,DIFROM 143 S XMTEXT="^TMP("""_XUSRTN_""","_$J_"," 144 S XMSUB=$TR($P($G(^TMP(XUSRTN,$J,1)),U),":")_"("_$G(XUSPROD)_") "_NVHEADR 145 D ^XMD 146 Q 1 XUSNPIX3 ;OAK_BP/CMW - NPI EXTRACT REPORT ;01-OCT-06 2 ;;8.0;KERNEL;**438,452,453**; Jul 10, 1995;Build 36 3 ;;Per VHA Directive 10-93-142, this routine should not be modified. 4 ; 5 ; NPI Extract Report 6 ; 7 ; Input parameter: N/A 8 ; 9 ; Other relevant variables: 10 ; XUSRTN="XUSNPIX1NV" (current routine name, used for ^XTMP and ^TMP 11 ; XUSRTN="XUSNPIX2NV" storage subscript) 12 ; Storage Global: 13 ; ^XTMP("XUSNPIX1VA",0) = Piece 1^Piece 2^Piece 3^Piece 4^Piece 5^Piece 6 14 ; ^XTMP("XUSNPIX2VA",0) 15 ; where: 16 ; Piece 1 => Purge Date - 1 year in future 17 ; Piece 2 => Create Date - Today 18 ; Piece 3 => Description 19 ; Piece 4 => Last Date Compiled 20 ; Piece 5 => $H last run start time 21 ; Piece 6 => $H last run completion time 22 ; 23 ; Entry Point - ENT called from XUSNPIX1 24 ; 25 Q 26 ; 27 ENT ; ENTRY POINT 28 ; init variables 29 N XUSRTN 30 N XUSNPI,XUSDATA,XUSTYP,XUST 31 N NVIEN,IBA0,PROTYPE,NPIDT,NPINEW 32 K ^TMP("XUSNPI",$J) 33 S XUST="",XUSCNT=2,MSGCNT=0 34 ; Loop through IB NON/OTHER VA BILLING PROVIDER records NPI xref 35 S XUSNPI=0 36 F S XUSNPI=$O(^IBA(355.93,"NPI",XUSNPI)) Q:'XUSNPI D 37 . S NVIEN=$O(^IBA(355.93,"NPI",XUSNPI,"")) 38 . S IBA0=$G(^IBA(355.93,NVIEN,0)) 39 . ; Get Provider Type 40 . S PROTYPE=$P(IBA0,U,2) 41 . S XUSTYP=$S(PROTYPE=1:2,1:1) 42 . ; setup NPI array 43 . S ^TMP("XUSNPI",$J,XUSTYP,XUSNPI)=NVIEN 44 . ; 45 ; If Provider Type is Individual 46 S XUSRTN="XUSNPIX1NV",NVHEADR=" NPI EXTRACT TYPE 1 (NON VA)",NVTYPE="TYPE 1 (NVA)" 47 I $D(^TMP("XUSNPI",$J,1)) D I XUST G EXIT 48 . ; Check to see if report is in use 49 . L +^XTMP(XUSRTN):5 I '$T S XUST=1 Q 50 . D INIT(XUSRTN) 51 . D INST(XUSRTN) 52 . D TYPE1^XUSNPIX4 53 . D EMAIL(XUSRTN) 54 . D VMAIL(XUSRTN) 55 . ; Log Run Completion Time 56 . S $P(^XTMP(XUSRTN,0),U,6)=$H 57 . L -^XTMP(XUSRTN) 58 ; 59 I '$D(^TMP("XUSNPI",$J,1)) D 60 . D INIT(XUSRTN) 61 . D INST(XUSRTN) 62 . S ^TMP(XUSRTN,$J,1)=XUSHDR_U_"Message Number: "_1_U_"Line Count: "_1_U_DTTM3_U_$G(XUSPROD)_XUSEOL 63 . S ^XTMP("XUSNPIXT","1NV")=1_U_0_U_DTTM3 64 . S ^TMP(XUSRTN,$J,2)="END OF FILE"_U_XUSEOL 65 . D EMAIL(XUSRTN),VMAIL(XUSRTN) 66 ; 67 ; If Provider Type is Facility/Group 68 S XUSRTN="XUSNPIX2NV",NVHEADR=" NPI EXTRACT TYPE 2 (NON VA)",NVTYPE="TYPE 2 (NVA)" 69 I $D(^TMP("XUSNPI",$J,2)) D I XUST G EXIT 70 . ; Check to see if report is in use 71 . L +^XTMP(XUSRTN):5 I '$T S XUST=1 Q 72 . D INIT(XUSRTN) 73 . D INST(XUSRTN) 74 . D TYPE2^XUSNPIX4 75 . D EMAIL(XUSRTN) 76 . D VMAIL(XUSRTN) 77 . ; Log Run Completion Time 78 . S $P(^XTMP(XUSRTN,0),U,6)=$H 79 . L -^XTMP(XUSRTN) 80 . ; 81 I '$D(^TMP("XUSNPI",$J,2)) D 82 . D INIT(XUSRTN) 83 . D INST(XUSRTN) 84 . S ^TMP(XUSRTN,$J,1)=XUSHDR_U_"Message Number: "_1_U_"Line Count: "_1_U_DTTM3_U_$G(XUSPROD)_XUSEOL 85 . S ^XTMP("XUSNPIXT","2NV")=1_U_0_U_DTTM3 86 . S ^TMP(XUSRTN,$J,2)="END OF FILE"_U_XUSEOL 87 . D EMAIL(XUSRTN),VMAIL(XUSRTN) 88 ; 89 EXIT ;Standard EXIT point 90 K ^TMP("XUSNPI",$J) 91 K XUSNV,P,LDTCMP,PTPMAIL,SITE,NVHEADR,NVTYPE,XUSEOL,DTTM3 92 K MAXSIZE,XUSHDR,XUSCNT,MSGCNT 93 ; 94 Q 95 ; 96 INIT(XUSRTN) ; check/init variables 97 N XUSDESC 98 ; Set end of line character 99 S XUSEOL="~~" 100 ; Set to 300000 for live 101 S MAXSIZE=300000 102 S DTTM3=$$HTE^XLFDT($H,"2") 103 ; 104 ;Reset Temporary Scratch Global 105 K ^TMP(XUSRTN) 106 S XUSDESC="NPI EXTRACT NON VA - Do Not Delete" 107 S ^XTMP(XUSRTN,0)=(DT+10000)_U_DT_U_XUSDESC_U_DT_U_$H 108 ; 109 I '$D(^TMP("XUSNPIXU",$J)) D BCBSID^XUSNPIXU 110 Q 111 ; 112 INST(XUSRTN) ;Pull station and Institution info 113 N INST,SINFO,DIC4 114 ; Pull site info 115 S SINFO=$$SITE^VASITE 116 ; Station Number 117 S SITE=$P(SINFO,U,3) 118 ; Institution 119 S INST=$P(SINFO,U) 120 ; 121 ; Get institution mailing address 122 I INST D 123 . S DIC4=$G(^DIC(4,INST,4)) 124 . S XUSNV(7)=$P(DIC4,U) 125 . S XUSNV(8)=$P(DIC4,U,2) 126 . S XUSNV(9)=$P(DIC4,U,3) 127 . S XUSNV(10)=$P(DIC4,U,4) 128 . I XUSNV(10) S XUSNV(10)=$P($G(^DIC(5,XUSNV(10),0)),U,2) 129 . S XUSNV(11)=$P(DIC4,U,5) 130 . S PTPMAIL=XUSNV(7)_U_XUSNV(8)_U_XUSNV(9)_U_XUSNV(10)_U_XUSNV(11) 131 S XUSHDR="Station: "_SITE_U_XUSNV(9)_U_XUSNV(10)_U_XUSNV(11)_U_NVTYPE_U_XUSVER 132 Q 133 ; 134 EMAIL(XUSRTN) ; EMAIL THE MESSAGE 135 N XMY 136 ; Send email to designated recipient for live release 137 S XMY("XXX@Q-NPS.VA.GOV")="" 138 ;S XMY(DUZ)="" ;use for testing - remove before live 139 D ESEND 140 Q 141 ; 142 VMAIL(XUSRTN) ; Verification email 143 N TMP 144 S TMP=^TMP(XUSRTN,$J,1) 145 K ^TMP(XUSRTN,$J) 146 S ^TMP(XUSRTN,$J,1)=$P(TMP,U,1,4) 147 S ^TMP(XUSRTN,$J,2)="" 148 S ^TMP(XUSRTN,$J,3)=NVHEADR_" (FILE #355.93)" 149 S ^TMP(XUSRTN,$J,4)="" 150 S ^TMP(XUSRTN,$J,5)="Date/Time of Extract: "_$P(TMP,U,9) 151 S ^TMP(XUSRTN,$J,6)="" 152 S ^TMP(XUSRTN,$J,7)="Message number: "_$S(MSGCNT>0:MSGCNT,1:1)_" Total NPI records: "_(XUSCNT-2) 153 S ^TMP(XUSRTN,$J,8)="" 154 S ^TMP(XUSRTN,$J,9)="Programmer Notes: "_XUSVER_" - "_$P(TMP,U,10) 155 ; 156 ; Send verification email to local mail group and VA Outlook mail group 157 S XMY("G.NPI EXTRACT VERIFICATION")="" 158 D ESEND 159 K ^TMP(XUSRTN) 160 Q 161 ; 162 ESEND N XMTEXT,XMSUB,XMDUN,XMDUZ,XMZ 163 S XMTEXT="^TMP("""_XUSRTN_""","_$J_"," 164 S XMSUB=$TR($P($G(^TMP(XUSRTN,$J,1)),U),":")_"("_$G(XUSPROD)_") "_NVHEADR 165 D ^XMD 166 Q -
WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPIX4.m
r613 r623 1 XUSNPIX4 ;OAK_BP/CMW - NPI EXTRACT REPORT ;11:47 AM 28 Jul 2009 2 ;;8.0;KERNEL;**438,452,453,481,WV**; Jul 10, 1995;Build 21 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 ; NPI Extract Report 6 ; 7 ; Input parameter: N/A 8 ; 9 ; Other relevant variables: 10 ; XUSRTN="XUSNPIX1NV" (current routine name, used for ^XTMP and ^TMP 11 ; XUSRTN="XUSNPIX2NV" storage subscript) 12 ; Storage Global: 13 ; ^XTMP("XUSNPIX1VA",0) = Piece 1^Piece 2^Piece 3^Piece 4^Piece 5^Piece 6 14 ; ^XTMP("XUSNPIX2VA",0) 15 ; where: 16 ; Piece 1 => Purge Date - 1 year in future 17 ; Piece 2 => Create Date - Today 18 ; Piece 3 => Description 19 ; Piece 4 => Last Date Compiled 20 ; Piece 5 => $H last run start time 21 ; Piece 6 => $H last run completion time 22 ; 23 ; Entry Point - ENT called from XUSNPIX1 24 ; 25 Q 26 ; 27 ; Individual records 28 TYPE1(DTTM3,PTPMAIL,SITE,XUSPROD,XUSHDR) ; 29 N IBA0,NVIEN,XUSNPI,MAXSIZE,XUSEOL,XUSCNT 30 N XUSI,XUSNM,XUSNV,XLFNC,XUSIZE,XUSDT,XUSNEW 31 N TOTREC1 32 ; 33 ; Set Maximum Message Size 34 S MAXSIZE=300000 35 ; 36 ; Set end of line character 37 S XUSEOL="~~" 38 ; 39 S XUSCNT=1,(TOTREC1,MSGCNT,XUSIZE)=0 40 S XUSNPI="" 41 F S XUSNPI=$O(^TMP("XUSNPI",$J,1,XUSNPI)) Q:'XUSNPI D 42 . S XUSDATA=XUSNPI 43 . S NVIEN=$G(^TMP("XUSNPI",$J,1,XUSNPI)) 44 . ; 45 . F XUSI=1:1:29 S XUSNV(XUSI)="" 46 . S IBA0=$G(^IBA(355.93,NVIEN,0)) 47 . S XUSNM=$P(IBA0,U) 48 . ; Break Name into components 49 . I XUSNM'="" D 50 . . ;Begin WorldVistA Change; 07/28/2009 51 . . ;S XLFNC=XUSNM D FORMAT^XLFNAME7(.XLFNC,,,,0) 52 . . S XLFNC=XUSNM S XLFNC=$$FORMAT^XLFNAME7(.XLFNC,,,,0) 53 . . ;End WorldVistA change 54 . . S XUSNV(2)=XLFNC("GIVEN"),XUSNV(3)=XLFNC("MIDDLE"),XUSNV(4)=XLFNC("FAMILY") 55 . . I XLFNC("SUFFIX")'="" S XUSNV(4)=XUSNV(4)_" "_XLFNC("SUFFIX") 56 . . K XLFNC 57 . S XUSDATA=XUSDATA_U_XUSNV(2)_U_XUSNV(3)_U_XUSNV(4) 58 . S XUSNV(5)=1 ;TYPE 59 . ; 60 . ; DOB (place holder) 61 . S XUSNV(6)="" 62 . S XUSDATA=XUSDATA_U_XUSNV(5)_U_XUSNV(6) 63 . ; 64 . ; Pay to Provider Address (7-11) 65 . S XUSDATA=XUSDATA_U_PTPMAIL 66 . ; 67 . ; Servicing Provider Address 68 . S XUSNV(12)=$P(IBA0,U,5) 69 . S XUSNV(13)=$P(IBA0,U,10) 70 . S XUSNV(14)=$P(IBA0,U,6) 71 . S XUSNV(15)=$P(IBA0,U,7) 72 . I XUSNV(15) S XUSNV(15)=$P($G(^DIC(5,XUSNV(12),0)),U,2) 73 . S XUSNV(16)=$P(IBA0,U,8) 74 . S XUSDATA=XUSDATA_U_XUSNV(12)_U_XUSNV(13)_U_XUSNV(14)_U_XUSNV(15)_U_XUSNV(16) 75 . ; 76 . ; Office Phone number (place holder) 77 . S XUSNV(17)="" 78 . ; 79 . ; Degree Description / Degree Code (place holder) 80 . S XUSNV(18)="" 81 . S XUSNV(19)="" 82 . ; 83 . ; Get Taxonomy and specialty codes 84 . N NVTX,NVSPC,NVTAX 85 . S NVTX=0 86 . F S NVTX=$O(^IBA(355.93,NVIEN,"TAXONOMY","B",NVTX)) Q:'NVTX D 87 . . S NVSPC=$P($G(^USC(8932.1,NVTX,0)),U,9) 88 . . S NVTAX=$P($G(^USC(8932.1,NVTX,0)),U,7) 89 . . I NVSPC'="" D 90 . . . I XUSNV(20)="" S XUSNV(20)=NVSPC Q 91 . . . S XUSNV(20)=XUSNV(20)_";"_NVSPC 92 . . I NVTAX'="" D 93 . . . I XUSNV(21)="" S XUSNV(21)=NVTAX Q 94 . . . S XUSNV(21)=XUSNV(21)_";"_NVTAX 95 . ; 96 . ; Fed tax ID 97 . S XUSNV(22)=$P($G(IBA0),U,9) 98 . ; 99 . S XUSDATA=XUSDATA_U_XUSNV(17)_U_XUSNV(18)_U_XUSNV(19)_U_XUSNV(20)_U_XUSNV(21)_U_XUSNV(22) 100 . ; 101 . ; Medicare Part A/B 102 . S XUSNV(23)=670899 103 . S XUSNV(24)="VA"_$E(SITE+10000,2,5) 104 . ; 105 . ; State Lic and DEA (place holder) 106 . S XUSNV(25)="" 107 . S XUSNV(26)="" 108 . ; 109 . ; VISN Station 110 . S XUSNV(27)=SITE 111 . ; 112 . S XUSDATA=XUSDATA_U_XUSNV(23)_U_XUSNV(24)_U_XUSNV(25)_U_XUSNV(26)_U_XUSNV(27) 113 . ; 114 . ;BCBS info 115 . K XUSBXID 116 . D NNVAID^XUSNPIXU(NVIEN,.XUSBXID) 117 . ; 118 . ;Update counter and save Entry 119 . N XUSB 120 . S XUSCNT=XUSCNT+1,TOTREC1=TOTREC1+1 121 . S ^TMP(XUSRTN,$J,XUSCNT)=XUSDATA_U_XUSEOL 122 . S XUSIZE=XUSIZE+$L(^TMP(XUSRTN,$J,XUSCNT)) 123 . I $D(XUSBXID) D 124 . . S XUSB="" 125 . . F S XUSB=$O(XUSBXID(XUSB)) Q:XUSB="" D 126 . . . S XUSCNT=XUSCNT+1,TOTREC1=TOTREC1+1 127 . . . S ^TMP(XUSRTN,$J,XUSCNT)=XUSDATA_U_XUSB_U_XUSEOL 128 . . . S XUSIZE=XUSIZE+$L(^TMP(XUSRTN,$J,XUSCNT)) 129 . I XUSIZE>MAXSIZE D 130 . . D EOF1(XUSRTN) 131 . . D EMAIL^XUSNPIX3(XUSRTN) 132 . . K ^TMP(XUSRTN,$J) 133 . . S ^TMP("XUSNPIXS",$J,3,MSGCNT)="1 (Non-VA)^"_(XUSCNT-2) 134 . . S ^TMP(XUSRTN,$J,1)=XUSHDR 135 . . S XUSCNT=1,XUSIZE=0 136 . K XUSNV,XUSDATA,XUSBXID 137 ; 138 D EOF1(XUSRTN) 139 ; 140 ; Send last message (if it has records) 141 I $G(XUSCNT)>1 D 142 . D EMAIL^XUSNPIX3(XUSRTN) 143 . K ^TMP(XUSRTN,$J) 144 . S ^TMP("XUSNPIXS",$J,3,MSGCNT)="1 (Non-VA)^"_($G(XUSCNT)-2) 145 ; 146 ; Update Summary 147 S ^XTMP("XUSNPIXT","1NV")=MSGCNT_U_TOTREC1_U_DTTM3 148 Q 149 ; 150 EOF1(XUSRTN) ; 151 Q:$G(XUSCNT)=1 152 S MSGCNT=MSGCNT+1 153 S ^TMP(XUSRTN,$J,1)=XUSHDR_U_"Message Number: "_MSGCNT_U_"Line Count: "_XUSCNT_U_DTTM3_U_$G(XUSPROD)_U_XUSEOL 154 S XUSCNT=XUSCNT+1 155 S ^TMP(XUSRTN,$J,XUSCNT)="END OF FILE"_U_XUSEOL 156 Q 157 ; 158 TYPE2(DTTM3,PTPMAIL,SITE,XUSPROD,XUSHDR) ;Facility/Group 159 N IBA0,NVIEN,XUSNPI,MAXSIZE,XUSEOL,XUSCNT 160 N XUSNV,XUSI,XUSNM,XLFNC,MSGCNT,XUSIZE,XUSDT,XUSNEW,TOTREC2 161 ; 162 ; Set Maximum Message Size 163 S MAXSIZE=300000 164 ; 165 ; Set end of line character 166 S XUSEOL="~~" 167 ; 168 S XUSNPI="" 169 S XUSCNT=1,(TOTREC2,MSGCNT,XUSIZE)=0 170 F S XUSNPI=$O(^TMP("XUSNPI",$J,2,XUSNPI)) Q:'XUSNPI D 171 . S XUSDATA=XUSNPI 172 . S NVIEN=$G(^TMP("XUSNPI",$J,2,XUSNPI)) 173 . ; 174 . F XUSI=1:1:24 S XUSNV(XUSI)="" 175 . S IBA0=$G(^IBA(355.93,NVIEN,0)) 176 . ;Get Organization name 177 . S XUSNV(2)=$P(IBA0,U) 178 . ;Type 179 . S XUSNV(3)=2 180 . ; 181 . S XUSDATA=XUSDATA_U_XUSNV(2)_U_XUSNV(3) 182 . ; 183 . ; Pay to Provider Address (4-8) 184 . S XUSDATA=XUSDATA_U_PTPMAIL 185 . ; 186 . ; Servicing Provider Address 187 . S XUSNV(9)=$P(IBA0,U,5) 188 . S XUSNV(10)=$P(IBA0,U,10) 189 . S XUSNV(11)=$P(IBA0,U,6) 190 . S XUSNV(12)=$P(IBA0,U,7) 191 . I XUSNV(12) S XUSNV(12)=$P($G(^DIC(5,XUSNV(12),0)),U,2) 192 . S XUSNV(13)=$P(IBA0,U,8) 193 . S XUSDATA=XUSDATA_U_XUSNV(9)_U_XUSNV(10)_U_XUSNV(11)_U_XUSNV(12)_U_XUSNV(13) 194 . ; 195 . ;Office Phone number (place holder) 196 . S XUSNV(14)="" 197 . ; 198 . ; get Taxonomy and Specialty 199 . N NVTX,NVSPC,NVTAX 200 . S NVTX=0 201 . F S NVTX=$O(^IBA(355.93,NVIEN,"TAXONOMY","B",NVTX)) Q:'NVTX D 202 . . S NVSPC=$P($G(^USC(8932.1,NVTX,0)),U,9) 203 . . S NVTAX=$P($G(^USC(8932.1,NVTX,0)),U,7) 204 . . I NVSPC'="" D 205 . . . I XUSNV(15)="" S XUSNV(15)=NVSPC Q 206 . . . S XUSNV(15)=XUSNV(15)_";"_NVSPC 207 . . I NVTAX'="" D 208 . . . I XUSNV(16)="" S XUSNV(16)=NVTAX Q 209 . . . S XUSNV(16)=XUSNV(16)_";"_NVTAX 210 . ; 211 . ; Fed Tax ID 212 . S XUSNV(17)=$P($G(IBA0),U,9) 213 . ; 214 . ;Medicare A/B 215 . S XUSNV(18)=670899 216 . S XUSNV(19)="VA"_$E(SITE+10000,2,5) 217 . ; 218 . S XUSDATA=XUSDATA_U_XUSNV(14)_U_XUSNV(15)_U_XUSNV(16)_U_XUSNV(17)_U_XUSNV(18)_U_XUSNV(19) 219 . ; 220 . ;State License Number 221 . S XUSNV(20)=$P($G(IBA0),U,12) 222 . ; 223 . ;DEA Number (place holder) 224 . S XUSNV(21)="" 225 . ; 226 . ;VISN STATION ID 227 . S XUSNV(22)=SITE 228 . ; 229 . S XUSDATA=XUSDATA_U_XUSNV(20)_U_XUSNV(21)_U_XUSNV(22) 230 . ; 231 . ;BCBS info 232 . K XUSBXID 233 . D NNVAID^XUSNPIXU(NVIEN,.XUSBXID) 234 . ; 235 . ;Update counter and save Entry 236 . N XUSB 237 . S XUSCNT=XUSCNT+1,TOTREC2=TOTREC2+1 238 . S ^TMP(XUSRTN,$J,XUSCNT)=XUSDATA_U_XUSEOL 239 . S XUSIZE=XUSIZE+$L(^TMP(XUSRTN,$J,XUSCNT)) 240 . I $D(XUSBXID) D 241 . . S XUSB="" 242 . . F S XUSB=$O(XUSBXID(XUSB)) Q:XUSB="" D 243 . . . S XUSCNT=XUSCNT+1,TOTREC2=TOTREC2+1 244 . . . S ^TMP(XUSRTN,$J,XUSCNT)=XUSDATA_U_XUSB_U_XUSEOL 245 . . . S XUSIZE=XUSIZE+$L(^TMP(XUSRTN,$J,XUSCNT)) 246 . I XUSIZE>MAXSIZE D 247 . . D EOF2(XUSRTN) 248 . . D EMAIL^XUSNPIX3(XUSRTN) 249 . . K ^TMP(XUSRTN,$J) 250 . . S ^TMP("XUSNPIXS",$J,4,MSGCNT)="2 (Non-VA)^"_(XUSCNT-2) 251 . . S ^TMP(XUSRTN,$J,1)=XUSHDR 252 . . S XUSCNT=1,XUSIZE=0 253 . K XUSNV,XUSDATA,XUSB,XUSBXID 254 ; 255 D EOF2(XUSRTN) 256 ; 257 ; Send last message (if it has records) 258 I $G(XUSCNT)>1 D 259 . D EMAIL^XUSNPIX3(XUSRTN) 260 . K ^TMP(XUSRTN,$J) 261 . S ^TMP("XUSNPIXS",$J,4,MSGCNT)="2 (Non-VA)^"_($G(XUSCNT)-2) 262 ; 263 ; Update Summary 264 S ^XTMP("XUSNPIXT","2NV")=MSGCNT_U_TOTREC2_U_DTTM3 265 Q 266 ; 267 EOF2(XUSRTN) ; 268 Q:$G(XUSCNT)=1 269 S MSGCNT=MSGCNT+1 270 S ^TMP(XUSRTN,$J,1)=XUSHDR_U_"Message Number: "_MSGCNT_U_"Line Count: "_XUSCNT_U_DTTM3_U_$G(XUSPROD)_U_XUSEOL 271 S XUSCNT=XUSCNT+1 272 S ^TMP(XUSRTN,$J,XUSCNT)="END OF FILE"_U_XUSEOL 273 Q 1 XUSNPIX4 ;OAK_BP/CMW - NPI EXTRACT REPORT ;01-OCT-06 2 ;;8.0;KERNEL;**438,452,453**; Jul 10, 1995;Build 36 3 ;;Per VHA Directive 10-93-142, this routine should not be modified. 4 ; 5 ; NPI Extract Report 6 ; 7 ; Input parameter: N/A 8 ; 9 ; Other relevant variables: 10 ; XUSRTN="XUSNPIX1NV" (current routine name, used for ^XTMP and ^TMP 11 ; XUSRTN="XUSNPIX2NV" storage subscript) 12 ; Storage Global: 13 ; ^XTMP("XUSNPIX1VA",0) = Piece 1^Piece 2^Piece 3^Piece 4^Piece 5^Piece 6 14 ; ^XTMP("XUSNPIX2VA",0) 15 ; where: 16 ; Piece 1 => Purge Date - 1 year in future 17 ; Piece 2 => Create Date - Today 18 ; Piece 3 => Description 19 ; Piece 4 => Last Date Compiled 20 ; Piece 5 => $H last run start time 21 ; Piece 6 => $H last run completion time 22 ; 23 ; Entry Point - ENT called from XUSNPIX1 24 ; 25 Q 26 ; 27 ; Individual records 28 TYPE1 ; 29 N IBA0,NVIEN,XUSNPI 30 N XUSI,XUSNM,XUSNV,XLFNC,XUSIZE,XUSDT,XUSNEW 31 N TOTREC1,TOTREC2 32 S XUSCNT=1,(TOTREC1,MSGCNT,XUSIZE)=0 33 S XUSNPI="" 34 F S XUSNPI=$O(^TMP("XUSNPI",$J,1,XUSNPI)) Q:'XUSNPI D 35 . S XUSDATA=XUSNPI 36 . S NVIEN=$G(^TMP("XUSNPI",$J,1,XUSNPI)) 37 . ; 38 . F XUSI=1:1:29 S XUSNV(XUSI)="" 39 . S IBA0=$G(^IBA(355.93,NVIEN,0)) 40 . S XUSNM=$P(IBA0,U) 41 . ; Break Name into components 42 . I XUSNM'="" D 43 . . S XLFNC=XUSNM D FORMAT^XLFNAME7(.XLFNC,,,,0) 44 . . S XUSNV(2)=XLFNC("GIVEN"),XUSNV(3)=XLFNC("MIDDLE"),XUSNV(4)=XLFNC("FAMILY") 45 . . I XLFNC("SUFFIX")'="" S XUSNV(4)=XUSNV(4)_" "_XLFNC("SUFFIX") 46 . . K XLFNC 47 . S XUSDATA=XUSDATA_U_XUSNV(2)_U_XUSNV(3)_U_XUSNV(4) 48 . S XUSNV(5)=1 ;TYPE 49 . ; 50 . ; DOB (place holder) 51 . S XUSNV(6)="" 52 . S XUSDATA=XUSDATA_U_XUSNV(5)_U_XUSNV(6) 53 . ; 54 . ; Pay to Provider Address (7-11) 55 . S XUSDATA=XUSDATA_U_PTPMAIL 56 . ; 57 . ; Servicing Provider Address 58 . S XUSNV(12)=$P(IBA0,U,5) 59 . S XUSNV(13)=$P(IBA0,U,10) 60 . S XUSNV(14)=$P(IBA0,U,6) 61 . S XUSNV(15)=$P(IBA0,U,7) 62 . I XUSNV(15) S XUSNV(15)=$P($G(^DIC(5,XUSNV(12),0)),U,2) 63 . S XUSNV(16)=$P(IBA0,U,8) 64 . S XUSDATA=XUSDATA_U_XUSNV(12)_U_XUSNV(13)_U_XUSNV(14)_U_XUSNV(15)_U_XUSNV(16) 65 . ; 66 . ; Office Phone number (place holder) 67 . S XUSNV(17)="" 68 . ; 69 . ; Degree Description / Degree Code (place holder) 70 . S XUSNV(18)="" 71 . S XUSNV(19)="" 72 . ; 73 . ; Get Taxonomy and specialty codes 74 . N NVTX,NVSPC,NVTAX 75 . S NVTX=0 76 . F S NVTX=$O(^IBA(355.93,NVIEN,"TAXONOMY","B",NVTX)) Q:'NVTX D 77 . . S NVSPC=$P($G(^USC(8932.1,NVTX,0)),U,9) 78 . . S NVTAX=$P($G(^USC(8932.1,NVTX,0)),U,7) 79 . . I NVSPC'="" D 80 . . . I XUSNV(20)="" S XUSNV(20)=NVSPC Q 81 . . . S XUSNV(20)=XUSNV(20)_";"_NVSPC 82 . . I NVTAX'="" D 83 . . . I XUSNV(21)="" S XUSNV(21)=NVTAX Q 84 . . . S XUSNV(21)=XUSNV(21)_";"_NVTAX 85 . ; 86 . ; Fed tax ID 87 . S XUSNV(22)=$P($G(IBA0),U,9) 88 . ; 89 . S XUSDATA=XUSDATA_U_XUSNV(17)_U_XUSNV(18)_U_XUSNV(19)_U_XUSNV(20)_U_XUSNV(21)_U_XUSNV(22) 90 . ; 91 . ; Medicare Part A/B 92 . S XUSNV(23)=670899 93 . S XUSNV(24)="VA"_$E(SITE+10000,2,5) 94 . ; 95 . ; State Lic and DEA (place holder) 96 . S XUSNV(25)="" 97 . S XUSNV(26)="" 98 . ; 99 . ; VISN Station 100 . S XUSNV(27)=SITE 101 . ; 102 . S XUSDATA=XUSDATA_U_XUSNV(23)_U_XUSNV(24)_U_XUSNV(25)_U_XUSNV(26)_U_XUSNV(27) 103 . ; 104 . ;BCBS info 105 . K XUSBXID 106 . D NNVAID^XUSNPIXU(NVIEN,.XUSBXID) 107 . ; 108 . ;Update counter and save Entry 109 . N XUSB 110 . S XUSCNT=XUSCNT+1,TOTREC1=TOTREC1+1 111 . S ^TMP(XUSRTN,$J,XUSCNT)=XUSDATA_U_XUSEOL 112 . S XUSIZE=XUSIZE+$L(^TMP(XUSRTN,$J,XUSCNT)) 113 . I $D(XUSBXID) D 114 . . S XUSB="" 115 . . F S XUSB=$O(XUSBXID(XUSB)) Q:XUSB="" D 116 . . . S XUSCNT=XUSCNT+1,TOTREC1=TOTREC1+1 117 . . . S ^TMP(XUSRTN,$J,XUSCNT)=XUSDATA_U_XUSB_U_XUSEOL 118 . . . S XUSIZE=XUSIZE+$L(^TMP(XUSRTN,$J,XUSCNT)) 119 . I XUSIZE>MAXSIZE D 120 . . D EOF1(XUSRTN) 121 . . D EMAIL^XUSNPIX3(XUSRTN) 122 . . D VMAIL^XUSNPIX3(XUSRTN) 123 . . S ^TMP(XUSRTN,$J,1)=XUSHDR 124 . . S XUSCNT=1,XUSIZE=0 125 . K XUSNV,XUSDATA,XUSBXID 126 ; 127 D EOF1(XUSRTN) 128 S ^XTMP("XUSNPIXT","1NV")=MSGCNT_U_TOTREC1_U_DTTM3 129 Q 130 ; 131 EOF1(XUSRTN) ; 132 S MSGCNT=MSGCNT+1 133 S ^TMP(XUSRTN,$J,1)=XUSHDR_U_"Message Number: "_MSGCNT_U_"Line Count: "_XUSCNT_U_DTTM3_U_$G(XUSPROD)_U_XUSEOL 134 S XUSCNT=XUSCNT+1 135 S ^TMP(XUSRTN,$J,XUSCNT)="END OF FILE"_U_XUSEOL 136 Q 137 ; 138 TYPE2 ;Facility/Group 139 N IBA0,NVIEN,XUSNPI 140 N XUSNV,XUSI,XUSNM,XLFNC,MSGCNT,XUSIZE,XUSDT,XUSNEW 141 S XUSNPI="" 142 S XUSCNT=1,(TOTREC2,MSGCNT,XUSIZE)=0 143 F S XUSNPI=$O(^TMP("XUSNPI",$J,2,XUSNPI)) Q:'XUSNPI D 144 . S XUSDATA=XUSNPI 145 . S NVIEN=$G(^TMP("XUSNPI",$J,2,XUSNPI)) 146 . ; 147 . F XUSI=1:1:24 S XUSNV(XUSI)="" 148 . S IBA0=$G(^IBA(355.93,NVIEN,0)) 149 . ;Get Organization name 150 . S XUSNV(2)=$P(IBA0,U) 151 . ;Type 152 . S XUSNV(3)=2 153 . ; 154 . S XUSDATA=XUSDATA_U_XUSNV(2)_U_XUSNV(3) 155 . ; 156 . ; Pay to Provider Address (4-8) 157 . S XUSDATA=XUSDATA_U_PTPMAIL 158 . ; 159 . ; Servicing Provider Address 160 . S XUSNV(9)=$P(IBA0,U,5) 161 . S XUSNV(10)=$P(IBA0,U,10) 162 . S XUSNV(11)=$P(IBA0,U,6) 163 . S XUSNV(12)=$P(IBA0,U,7) 164 . I XUSNV(12) S XUSNV(12)=$P($G(^DIC(5,XUSNV(12),0)),U,2) 165 . S XUSNV(13)=$P(IBA0,U,8) 166 . S XUSDATA=XUSDATA_U_XUSNV(9)_U_XUSNV(10)_U_XUSNV(11)_U_XUSNV(12)_U_XUSNV(13) 167 . ; 168 . ;Office Phone number (place holder) 169 . S XUSNV(14)="" 170 . ; 171 . ; get Taxonomy and Specialty 172 . N NVTX,NVSPC,NVTAX 173 . S NVTX=0 174 . F S NVTX=$O(^IBA(355.93,NVIEN,"TAXONOMY","B",NVTX)) Q:'NVTX D 175 . . S NVSPC=$P($G(^USC(8932.1,NVTX,0)),U,9) 176 . . S NVTAX=$P($G(^USC(8932.1,NVTX,0)),U,7) 177 . . I NVSPC'="" D 178 . . . I XUSNV(15)="" S XUSNV(15)=NVSPC Q 179 . . . S XUSNV(15)=XUSNV(15)_";"_NVSPC 180 . . I NVTAX'="" D 181 . . . I XUSNV(16)="" S XUSNV(16)=NVTAX Q 182 . . . S XUSNV(16)=XUSNV(16)_";"_NVTAX 183 . ; 184 . ; Fed Tax ID 185 . S XUSNV(17)=$P($G(IBA0),U,9) 186 . ; 187 . ;Medicare A/B 188 . S XUSNV(18)=670899 189 . S XUSNV(19)="VA"_$E(SITE+10000,2,5) 190 . ; 191 . S XUSDATA=XUSDATA_U_XUSNV(14)_U_XUSNV(15)_U_XUSNV(16)_U_XUSNV(17)_U_XUSNV(18)_U_XUSNV(19) 192 . ; 193 . ;State License Number 194 . S XUSNV(20)=$P($G(IBA0),U,12) 195 . ; 196 . ;DEA Number (place holder) 197 . S XUSNV(21)="" 198 . ; 199 . ;VISN STATION ID 200 . S XUSNV(22)=SITE 201 . ; 202 . S XUSDATA=XUSDATA_U_XUSNV(20)_U_XUSNV(21)_U_XUSNV(22) 203 . ; 204 . ;BCBS info 205 . K XUSBXID 206 . D NNVAID^XUSNPIXU(NVIEN,.XUSBXID) 207 . ; 208 . ;Update counter and save Entry 209 . N XUSB 210 . S XUSCNT=XUSCNT+1,TOTREC2=TOTREC2+1 211 . S ^TMP(XUSRTN,$J,XUSCNT)=XUSDATA_U_XUSEOL 212 . S XUSIZE=XUSIZE+$L(^TMP(XUSRTN,$J,XUSCNT)) 213 . I $D(XUSBXID) D 214 . . S XUSB="" 215 . . F S XUSB=$O(XUSBXID(XUSB)) Q:XUSB="" D 216 . . . S XUSCNT=XUSCNT+1,TOTREC2=TOTREC2+1 217 . . . S ^TMP(XUSRTN,$J,XUSCNT)=XUSDATA_U_XUSB_U_XUSEOL 218 . . . S XUSIZE=XUSIZE+$L(^TMP(XUSRTN,$J,XUSCNT)) 219 . I XUSIZE>MAXSIZE D 220 . . D EOF2(XUSRTN) 221 . . D EMAIL^XUSNPIX3(XUSRTN) 222 . . D VMAIL^XUSNPIX3(XUSRTN) 223 . . S ^TMP(XUSRTN,$J,1)=XUSHDR 224 . . S XUSCNT=1,XUSIZE=0 225 . K XUSNV,XUSDATA,XUSB,XUSBXID 226 ; 227 D EOF2(XUSRTN) 228 S ^XTMP("XUSNPIXT","2NV")=MSGCNT_U_TOTREC2_U_DTTM3 229 Q 230 ; 231 EOF2(XUSRTN) ; 232 S MSGCNT=MSGCNT+1 233 S ^TMP(XUSRTN,$J,1)=XUSHDR_U_"Message Number: "_MSGCNT_U_"Line Count: "_XUSCNT_U_DTTM3_U_$G(XUSPROD)_U_XUSEOL 234 S XUSCNT=XUSCNT+1 235 S ^TMP(XUSRTN,$J,XUSCNT)="END OF FILE"_U_XUSEOL 236 Q -
WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPIX5.m
r613 r623 1 XUSNPIX5 ;OAK_BP/CMW - NPI EXTRACT REPORT ;7/7/08 17:45 2 ;;8.0;KERNEL;**453,481**; Jul 10, 1995;Build 21 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 ; NPI Extract Report Mailer routine 6 ; 7 ; Input parameter: XUSRTN 8 ; 9 ; Other relevant variables: 10 ; XUSRTN="XUSNPIX1" (current routine name, used for ^XTMP and ^TMP 11 ; storage subscript) 12 ; Storage Global: 13 ; ^XTMP("XUSNPIX1",0) = Piece 1^Piece 2^Piece 3^Piece 4^Piece 5^Piece 6 14 ; where: 15 ; Piece 1 => Purge Date - 1 year in future 16 ; Piece 2 => Create Date - Today 17 ; Piece 3 => Description 18 ; Piece 4 => Last Date Compiled 19 ; Piece 5 => $H last run start time 20 ; Piece 6 => $H last run completion time 21 ; 22 ; ^XTMP("XUSNPIX1",1) = DATA 23 ; 24 ; XUSNPI => Unique NPI of entry 25 ; LDT => Last Date Run, VA Fileman Format 26 ; 27 Q 28 ; 29 EMAIL(XUSRTN) ; EMAIL THE MESSAGE 30 ; Add domain name if it does not exist 31 N XUSFOC,DLAYGO,DA,DIC,DIE,DR,X,Y 32 I '$$FIND1^DIC(4.2,,"QX","Q-NPS.VA.GOV","B") D 33 . S XUSFOC=$O(^DIC(4.2,"B","FOC-AUSTIN.VA.GOV",0)) I 'XUSFOC Q 34 . I XUSFOC=$O(^DIC(4.2,"B","FOC-AUSTIN.VA.GOV",""),-1) D 35 . . S DIC="^DIC(4.2,",X="Q-NPS.VA.GOV",DIC(0)="L",DLAYGO=4.2 D ^DIC K DLAYGO 36 . . S DIE=DIC,DA=+Y 37 . . S DR="1///NS;2///^S X=XUSFOC;1.7///YES;6.2///NPS;" 38 . . D ^DIE 39 ; 40 N XMY 41 ; Send email to designated recipient for live release 42 S XMY("XXX@Q-NPS.VA.GOV")="" 43 D ESEND 44 Q 45 ; 46 SMAIL(XUSRTN,XUSPROD,XUSVER,DTTM) ; Summary email 47 N HYPHEN,L,M,N,T,TMP,T1,T2,T1NV,T2NV,XMY 48 K ^TMP(XUSRTN,$J) 49 S T1=$G(^XTMP(XUSRTN,1)) 50 S T2=$G(^XTMP(XUSRTN,2)) 51 S T1NV=$G(^XTMP(XUSRTN,"1NV")) 52 S T2NV=$G(^XTMP(XUSRTN,"2NV")) 53 S ^TMP(XUSRTN,$J,1)="SUMMARY" 54 S ^TMP(XUSRTN,$J,2)="-------" 55 S ^TMP(XUSRTN,$J,3)=^XTMP(XUSRTN,"H")_" "_DTTM 56 S ^TMP(XUSRTN,$J,4)="" 57 S ^TMP(XUSRTN,$J,5)="Type 1 NEW PERSON FILE (#200) "_$J(+$P(T1,U),3)_" Message(s) Totaling "_$J(+$P(T1,U,2),7)_" NPI records." 58 S ^TMP(XUSRTN,$J,6)="Type 2 INSITUTION FILE (#4) "_$J(+$P(T2,U),3)_" Message(s) Totaling "_$J(+$P(T2,U,2),7)_" NPI records." 59 S ^TMP(XUSRTN,$J,7)="Type 1 NON VA Individual (#355.93) "_$J(+$P(T1NV,U),3)_" Message(s) Totaling "_$J(+$P(T1NV,U,2),7)_" NPI records." 60 S ^TMP(XUSRTN,$J,8)="Type 2 NON VA Facility/Group (#355.93) "_$J(+$P(T2NV,U),3)_" Message(s) Totaling "_$J(+$P(T2NV,U,2),7)_" NPI records." 61 S ^TMP(XUSRTN,$J,9)="" 62 S ^TMP(XUSRTN,$J,10)="Programmer Notes: "_XUSVER_" - "_$G(XUSPROD) 63 ; 64 ;Summary Detail 65 ; 66 S HYPHEN="",$P(HYPHEN,"-",84)="-" 67 ; 68 S ^TMP(XUSRTN,$J,11)="" 69 S ^TMP(XUSRTN,$J,12)=HYPHEN 70 S ^TMP(XUSRTN,$J,13)="" 71 S ^TMP(XUSRTN,$J,14)="MESSAGE DETAILS" 72 S ^TMP(XUSRTN,$J,15)="---------------" 73 S ^TMP(XUSRTN,$J,16)="" 74 S ^TMP(XUSRTN,$J,17)="TYPE "_$J("MESSAGE NUMBER",20)_$J("RECORD COUNT",20) 75 S ^TMP(XUSRTN,$J,18)="----------"_$J("--------------",20)_$J("------------",20) 76 ; 77 S L=18,T="" F S T=$O(^TMP("XUSNPIXS",$J,T)) Q:'T S M=0 F S M=$O(^TMP("XUSNPIXS",$J,T,M)) Q:'M D 78 .S N=$G(^TMP("XUSNPIXS",$J,T,M)) 79 .S L=L+1 80 .S ^TMP(XUSRTN,$J,L)=$E($P(N,U)_" ",1,10)_$J(M,16)_$J($P(N,U,2),24) 81 S L=L+1,^TMP(XUSRTN,$J,L)="" 82 S L=L+1,^TMP(XUSRTN,$J,L)=HYPHEN 83 ; Send verification email to local mail group and VA Outlook mail group 84 S XMY("G.NPI EXTRACT VERIFICATION")="" 85 N XMTEXT,XMSUB,XMDUN,XMDUZ,XMZ,XMMG,DIFROM 86 S XMTEXT="^TMP("""_XUSRTN_""","_$J_"," 87 S XMSUB=$TR($P(^XTMP(XUSRTN,"H"),U),":")_"("_$G(XUSPROD)_") NPI CROSSWALK EXTRACT SUMMARY " 88 D ^XMD 89 K ^TMP(XUSRTN,$J) 90 Q 91 ; 92 ESEND N XMTEXT,XMSUB,XMDUN,XMDUZ,XMZ,XMMG,DIFROM 93 S XMTEXT="^TMP("""_XUSRTN_""","_$J_"," 94 S XMSUB=$TR($P($G(^TMP(XUSRTN,$J,1)),U),":")_"("_$G(XUSPROD)_") NPI EXTRACT TYPE 1 " 95 D ^XMD 96 Q 1 XUSNPIX5 ;OAK_BP/CMW - NPI EXTRACT REPORT ;01-OCT-06 2 ;;8.0;KERNEL;**453**; Jul 10, 1995;Build 36 3 ;;Per VHA Directive 10-93-142, this routine should not be modified. 4 ; 5 ; NPI Extract Report Mailer routine 6 ; 7 ; Input parameter: XUSRTN 8 ; 9 ; Other relevant variables: 10 ; XUSRTN="XUSNPIX1" (current routine name, used for ^XTMP and ^TMP 11 ; storage subscript) 12 ; Storage Global: 13 ; ^XTMP("XUSNPIX1",0) = Piece 1^Piece 2^Piece 3^Piece 4^Piece 5^Piece 6 14 ; where: 15 ; Piece 1 => Purge Date - 1 year in future 16 ; Piece 2 => Create Date - Today 17 ; Piece 3 => Description 18 ; Piece 4 => Last Date Compiled 19 ; Piece 5 => $H last run start time 20 ; Piece 6 => $H last run completion time 21 ; 22 ; ^XTMP("XUSNPIX1",1) = DATA 23 ; 24 ; XUSNPI => Unique NPI of entry 25 ; LDT => Last Date Run, VA Fileman Format 26 ; 27 Q 28 ; 29 EMAIL(XUSRTN) ; EMAIL THE MESSAGE 30 ; Add domain name if it does not exist 31 N XUSFOC,DLAYGO,DA,DIC,DIE,DR,X,Y 32 I '$$FIND1^DIC(4.2,,"QX","Q-NPS.VA.GOV","B") D 33 . S XUSFOC=$O(^DIC(4.2,"B","FOC-AUSTIN.VA.GOV",0)) I 'XUSFOC Q 34 . I XUSFOC=$O(^DIC(4.2,"B","FOC-AUSTIN.VA.GOV",""),-1) D 35 . . S DIC="^DIC(4.2,",X="Q-NPS.VA.GOV",DIC(0)="L",DLAYGO=4.2 D ^DIC K DLAYGO 36 . . S DIE=DIC,DA=+Y 37 . . S DR="1///NS;2///^S X=XUSFOC;1.7///YES;6.2///NPS;" 38 . . D ^DIE 39 ; 40 N XMY 41 ; Send email to designated recipient for live release 42 S XMY("XXX@Q-NPS.VA.GOV")="" 43 ;S XMY(DUZ)="" ;use for testing - remove before live 44 D ESEND 45 Q 46 ; 47 VMAIL(XUSRTN) ; Verification email 48 N TMP 49 S TMP=^TMP(XUSRTN,$J,1) 50 K ^TMP(XUSRTN,$J) 51 S ^TMP(XUSRTN,$J,1)=$P(TMP,U,1,4) 52 S ^TMP(XUSRTN,$J,2)="" 53 S ^TMP(XUSRTN,$J,3)="TYPE 1 : NEW PERSON FILE (#200)" 54 S ^TMP(XUSRTN,$J,4)="" 55 S ^TMP(XUSRTN,$J,5)="Date/Time of Extract: "_$P(TMP,U,9) 56 S ^TMP(XUSRTN,$J,6)="" 57 S ^TMP(XUSRTN,$J,7)="Message number: "_MSGCNT_" Total NPI records: "_(COUNT-2) 58 S ^TMP(XUSRTN,$J,8)="" 59 S ^TMP(XUSRTN,$J,9)="Programmer Notes: "_XUSVER_" - "_$P(TMP,U,10) 60 ; 61 ; Send verification email to local mail group and VA Outlook mail group. 62 S XMY("G.NPI EXTRACT VERIFICATION")="" 63 D ESEND 64 K ^TMP(XUSRTN) 65 Q 66 ; 67 SMAIL(XUSRTN) ; Summary email 68 N TMP,T1,T2,T1NV,T2NV 69 K ^TMP(XUSRTN,$J) 70 S T1=$G(^XTMP(XUSRTN,1)) 71 S T2=$G(^XTMP(XUSRTN,2)) 72 S T1NV=$G(^XTMP(XUSRTN,"1NV")) 73 S T2NV=$G(^XTMP(XUSRTN,"2NV")) 74 S ^TMP(XUSRTN,$J,1)=^XTMP(XUSRTN,"H")_" - SUMMARY for "_DTTM 75 S ^TMP(XUSRTN,$J,2)="" 76 S ^TMP(XUSRTN,$J,3)="NEW PERSON FILE (#200) "_+$P(T1,U)_" Message(s) Totaling "_+$P(T1,U,2)_" NPI records." 77 S ^TMP(XUSRTN,$J,4)="" 78 S ^TMP(XUSRTN,$J,5)="INSITUTION FILE (#4) "_+$P(T2,U)_" Message(s) Totaling "_+$P(T2,U,2)_" NPI records." 79 S ^TMP(XUSRTN,$J,6)="" 80 S ^TMP(XUSRTN,$J,7)="NON VA Individual (#355.93) "_+$P(T1NV,U)_" Message(s) Totaling "_+$P(T1NV,U,2)_" NPI records." 81 S ^TMP(XUSRTN,$J,8)="" 82 S ^TMP(XUSRTN,$J,9)="NON VA Facility/Group (#355.93) "_+$P(T2NV,U)_" Message(s) Totaling "_+$P(T2NV,U,2)_" NPI records." 83 S ^TMP(XUSRTN,$J,10)="" 84 S ^TMP(XUSRTN,$J,11)="Programmer Notes: "_XUSVER_" - "_$G(XUSPROD) 85 ; 86 ; Send verification email to local mail group and VA Outlook mail group 87 S XMY("G.NPI EXTRACT VERIFICATION")="" 88 N XMTEXT,XMSUB,XMDUN,XMDUZ,XMZ 89 S XMTEXT="^TMP("""_XUSRTN_""","_$J_"," 90 S XMSUB=$TR($P($G(^TMP(XUSRTN,$J,1)),U),":")_"("_$G(XUSPROD)_") NPI EXTRACT SUMMARY " 91 D ^XMD 92 Q 93 K ^TMP(XUSRTN) 94 Q 95 ; 96 ESEND N XMTEXT,XMSUB,XMDUN,XMDUZ,XMZ 97 S XMTEXT="^TMP("""_XUSRTN_""","_$J_"," 98 S XMSUB=$TR($P($G(^TMP(XUSRTN,$J,1)),U),":")_"("_$G(XUSPROD)_") NPI EXTRACT TYPE 1 " 99 D ^XMD 100 Q -
WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZIS.m
r613 r623 1 %ZIS ;SFISC/AC,RWF -- DEVICE HANDLER ;1/24/08 16:06 2 ;;8.0;KERNEL;**18,23,69,112,199,191,275,363,440**;JUL 10, 1995;Build 13 3 ;Per VHA Directive 2004-038, this routine should not be modified 4 N %ZISOS,%ZISV 5 S U="^",%ZISOS=$G(^%ZOSF("OS")),%ZISV=$G(^%ZOSF("VOL")) 6 ;Check SPOOLER special case first 7 INIT I $D(ZTQUEUED),$G(IOT)="SPL",$D(IO)#2,$D(IO(0))#2,IO]"",IO=IO(0),$D(IO(1,IO))#2,%ZISOS["VAX DSM"!(%ZISOS["M/VX"),$G(IOP)[ION!(IOP[IO) K %ZIS,%IS,IOP Q 8 ; 9 I '$D(%ZIS),$D(%IS) M %ZIS=%IS 10 S:'($D(%ZIS)#2) %ZIS="M" M %IS=%ZIS ;update %IS for now 11 I '$D(^XUTL("XQ",$J,"MIXED OS")) S ^XUTL("XQ",$J,"MIXED OS")=$$PRI^%ZOSV 12 S %ZIS("PRI")=$G(^XUTL("XQ",$J,"MIXED OS"),1) 13 ; 14 I $D(ZTQUEUED) D I '$D(IOP) S POP=1 G EXIT^%ZIS1 15 .I $D(ZTIO)#2,ZTIO="" S:%IS'[0 %IS=%IS_"0",%ZIS=%ZIS_"0" 16 I '$D(ZTQUEUED),%IS["T",$P($G(IOP),";")="Q" S POP=1 G EXIT^%ZIS1 17 N %,%A,%E,%H,%I,%X,%XX,%Y,%Z,%Z1,%Z2,%Z9,%Z90,%Z91,%Z95,%ZISB,%ZTIME,%ZTYPE 18 N %ZHFN,%ZISOLD,DTOUT,DUOUT 19 ;Save symbols to restore if don't open a device 20 D SYMBOL^%ZISUTL(0,$NA(%ZISOLD)) 21 A D CLEAN ;(p363) K IO("CLOSE"),IO("HFSIO") 22 K IO("P"),IO("Q"),IO("S"),IO("T") 23 K2 D K2^%ZIS1 24 S %ZISB=%ZIS'["N",(%E,%H,POP)=0,%Y="" S:'$D(IO(0)) IO(0)=$I 25 I %ZISOS["VAX DSM",$I["SYS$INPUT:.;" S:%ZIS'[0 %IS=%IS_"0",%ZIS=%ZIS_"0" 26 ;I %IS["T"&(%IS["0") S (%H,%E)=0 G ^%ZIS1 27 I $D(IOP),IOP=$I!(IOP="HOME")!(0[IOP),$D(^XUTL("XQ",$J,"IO")) D HOME K %IS,%Y,%ZIS,%ZISB,%ZISV,IOP Q 28 ;Don't worry about HOME if %ZIS[0 29 D:%ZIS'[0 GETHOME G EXIT^%ZIS1:POP,^%ZIS1 ;Jump to next part 30 ; 31 GETHOME I $D(IO("HOME")),$P(IO("HOME"),"^",2)=IO(0) S (%E,%H)=+IO("HOME") Q 32 I $D(^XUTL("XQ",$J,"IOS")),$D(^("IO")),IO(0)=^("IO") S (%E,%H)=^("IOS") Q 33 ;CALL LINEPORT CODE HERE--- 34 S %=$$LINEPORT^%ZISUTL I % S (%E,%H)=% Q 35 S %ZISVT=$I D VTLKUP I '%E S %ZISVT=$I D VIRTUAL 36 I %ZISVT=""!(%E'>0) I %IS'[0 O IO(0)::0 I $T U IO(0) W !,"HOME DEVICE ("_$I_") DOES NOT EXIST IN THE DEVICE FILE",!,"PLEASE CONTACT YOUR SYSTEM MANAGER!",*7 37 S %H=%E S:'%H&(%IS'[0) POP=1 S:(%H>0)&('$D(IO("HOME"))) IO("HOME")=%H_"^"_$I 38 Q 39 VIRTUAL ;See if a Virtual Terminal (LAT, TELNET) 40 ;Change the MSM check for telnet to work with v4.4 41 I %ZISOS["MSM" X "I $P($ZV,""Version "",2)'<3 S %ZISVT=$ZDE(+%ZISVT) I %ZISVT?.E1""~""4.5N.E S %ZISVT=""TELNET""" 42 F %ZISI=$L(%ZISVT):-1:0 D:$D(^%ZIS(1,"C",%ZISVT)) Q:$S('%E:0,'$D(^%ZIS(1,%E,"TYPE")):0,^("TYPE")="VTRM":1,1:0) S %ZISVT=$E(%ZISVT,1,%ZISI) 43 .D VTLKUP Q:$S('%E:0,'$D(^%ZIS(1,%E,"TYPE")):0,^("TYPE")="VTRM":1,1:0) 44 .S %X=0 F %ZISX=%ZISV,"" Q:%X>0 S %X=0 F S %E=+$O(^%ZIS(1,"CPU",%ZISX_"."_%ZISVT,%X)) S %X=%E Q:%E'>0 I $G(^%ZIS(1,+%E,"TYPE"))="VTRM" Q 45 Q 46 VTLKUP F %ZISX=%ZISV,"" S %E=+$O(^%ZIS(1,"G","SYS."_%ZISX_"."_%ZISVT,0)) Q:%E S %E=+$O(^%ZIS(1,"CPU",%ZISX_"."_%ZISVT,0)) Q:%E 47 Q 48 ; 49 CURRENT N POP,%ZIS,%IS,%E,%H 50 S FF="#",SL=24,BS="*8",RM=80,(SUB,XY)="",%IS=0,%ZISOS=$G(^%ZOSF("OS")),%ZISV=$G(^("VOL")),POP=0 51 D GETHOME K %E,%IS,%ZISI,%ZISOS,%ZISV,%ZISVT,%ZISX Q:POP 52 I $D(^%ZIS(1,%H,"SUBTYPE")) S SUB=+^("SUBTYPE") K %H 53 I $D(SUB),SUB,$D(^%ZIS(2,SUB,1)) S SUB=$S($D(^(0)):$P(^(0),"^"),1:""),FF=$P(^(1),"^",2),SL=$P(^(1),"^",3),BS=$P(^(1),"^",4),XY=$P(^(1),"^",5),RM=+^(1) 54 E S SUB="" 55 I $D(^%ZOSF("RM")) N X S X=RM X ^("RM") K %A 56 Q 57 HOME ;Entry point to establish IO* variables for home device. 58 D CLEAN ;(p363) 59 N X I '$D(^XUTL("XQ",$J,"IO")) S IOP="HOME" D ^%ZIS Q 60 D RESETVAR 61 I '$D(IO("C")),$G(IOM),IO=$I,$D(IO(1,IO)),$D(^%ZOSF("RM")) S X=+IOM X ^("RM") 62 Q 63 ;IO("Q") is checked by many routines after a call to ^%ZISC, so only clean on call to %ZIS. 64 CLEAN ;Cleanup env. Called from %ZISC also. 65 I $G(IOT)'="SPL" K IO("DOC"),IO("SPOOL") ;(p446) 66 I $G(IOT)'="HFS" K IO("HFSIO") ;p446 67 S (IOPAR,IOUPAR)="" 68 Q 69 ; 70 RESETVAR ;Reset home IO* variables. 71 I '$D(^XUTL("XQ",$J,"IO")) Q 72 N % 73 F %="IO","IOBS","IOF","IOM","ION","IOS","IOSL","IOST","IOST(0)","IOT","IOXY","IOPAR","IOUPAR" I $D(^XUTL("XQ",$J,%))#2 S @%=^(%) 74 F %="IO(""IP"")","IO(""CLNM"")","IO(""DOC"")","IO(""HFSIO"")","IO(""SPOOL"")" I $D(^XUTL("XQ",$J,%))#2 S @%=^(%) 75 S POP=0,IO(0)=IO 76 Q 77 SAVEVAR ;Save home IO* variables, called from XUS1,%ZTMS3 78 N % 79 F %="IO","IOBS","IOF","IOM","ION","IOS","IOSL","IOST","IOST(0)","IOT","IOXY","IOPAR","IOUPAR" I $D(@%) S ^XUTL("XQ",$J,%)=@% 80 F %="IO(""IP"")","IO(""CLNM"")","IO(""DOC"")","IO(""HFSIO"")","IO(""SPOOL"")" I $D(@%) S ^XUTL("XQ",$J,%)=@% 81 Q 82 ZISLPC Q ;No longer called in Kernel v8. 83 ; 84 HLP1 G EN1^%ZIS7 85 HLP2 N %E,%H,%X,%ZISV,X S %ZISV=$S($D(^%ZOSF("VOL")):^("VOL"),1:"") G EN2^%ZIS7 86 ; 87 REWIND(IO2,IOT,IOPAR) ;Rewind Device 88 N %,X,Y,$ES,$ET S $ET="D REWERR^%ZIS Q 0" 89 S %=$I 90 I '($D(IO2)#2)!'$D(IOT)!'$D(IOPAR) Q 0 91 I "MT^SDP^HFS"'[IOT Q 0 92 S @("Y=$$REW"_IOT_"^%ZIS4(IO2,IOPAR)") 93 U % 94 Q Y 95 REWERR ;Error encountered 96 S IO("ERROR")=$EC 97 S $EC="",$ET="Q:$ES>1 S $EC="""" Q 0" S $EC=",U1," 98 Q 0 99 ; 1 %ZIS ;SFISC/AC,RWF -- DEVICE HANDLER ;10/14/2004 08:46 2 ;;8.0;KERNEL;**18,23,69,112,199,191,275,363**;JUL 10, 1995 3 N %ZISOS,%ZISV 4 S U="^",%ZISOS=$G(^%ZOSF("OS")),%ZISV=$G(^%ZOSF("VOL")) 5 ;Check SPOOLER special case first 6 INIT I $D(ZTQUEUED),$G(IOT)="SPL",$D(IO)#2,$D(IO(0))#2,IO]"",IO=IO(0),$D(IO(1,IO))#2,%ZISOS["VAX DSM"!(%ZISOS["M/VX"),$G(IOP)[ION!(IOP[IO) K %ZIS,%IS,IOP Q 7 ; 8 I '$D(%ZIS),$D(%IS) M %ZIS=%IS 9 S:'($D(%ZIS)#2) %ZIS="M" M %IS=%ZIS ;update %IS for now 10 ; 11 I $D(ZTQUEUED) D I '$D(IOP) S POP=1 G EXIT^%ZIS1 12 .I $D(ZTIO)#2,ZTIO="" S:%IS'[0 %IS=%IS_"0",%ZIS=%ZIS_"0" 13 I '$D(ZTQUEUED),%IS["T",$P($G(IOP),";")="Q" S POP=1 G EXIT^%ZIS1 14 N %,%A,%E,%H,%I,%X,%XX,%Y,%Z,%Z1,%Z9,%Z90,%Z91,%Z95,%ZISB,%ZTIME,%ZTYPE 15 N %ZHFN,%ZISOLD,DTOUT,DUOUT 16 ;Save symbols to restore if don't open a device 17 D SYMBOL^%ZISUTL(0,$NA(%ZISOLD)) 18 A D CLEAN ;(p363) K IO("CLOSE"),IO("HFSIO") 19 K IO("P"),IO("Q"),IO("S"),IO("T") 20 K2 D K2^%ZIS1 21 S %ZISB=%ZIS'["N",(%E,%H,POP)=0,%Y="" S:'$D(IO(0)) IO(0)=$I 22 I %ZISOS["VAX DSM",$I["SYS$INPUT:.;" S:%ZIS'[0 %IS=%IS_"0",%ZIS=%ZIS_"0" 23 ;I %IS["T"&(%IS["0") S (%H,%E)=0 G ^%ZIS1 24 I $D(IOP),IOP=$I!(IOP="HOME")!(0[IOP),$D(^XUTL("XQ",$J,"IO")) D HOME K %IS,%Y,%ZIS,%ZISB,%ZISV,IOP Q 25 ;Don't worry about HOME if %ZIS[0 26 D:%ZIS'[0 GETHOME G EXIT^%ZIS1:POP,^%ZIS1 ;Jump to next part 27 ; 28 GETHOME I $D(IO("HOME")),$P(IO("HOME"),"^",2)=IO(0) S (%E,%H)=+IO("HOME") Q 29 I $D(^XUTL("XQ",$J,"IOS")),$D(^("IO")),IO(0)=^("IO") S (%E,%H)=^("IOS") Q 30 ;CALL LINEPORT CODE HERE--- 31 S %=$$LINEPORT^%ZISUTL I % S (%E,%H)=% Q 32 S %ZISVT=$I D VTLKUP I '%E S %ZISVT=$I D VIRTUAL 33 I %ZISVT=""!(%E'>0) I %IS'[0 O IO(0)::0 I $T U IO(0) W !,"HOME DEVICE DOES NOT EXIST IN THE DEVICE FILE",!,"PLEASE CONTACT YOUR SYSTEM MANAGER!",*7 34 S %H=%E S:'%H&(%IS'[0) POP=1 S:(%H>0)&('$D(IO("HOME"))) IO("HOME")=%H_"^"_$I 35 Q 36 VIRTUAL ;See if a Virtual Terminal (LAT, TELNET) 37 ;Change the MSM check for telnet to work with v4.4 38 I %ZISOS["MSM" X "I $P($ZV,""Version "",2)'<3 S %ZISVT=$ZDE(+%ZISVT) I %ZISVT?.E1""~""4.5N.E S %ZISVT=""TELNET""" 39 F %ZISI=$L(%ZISVT):-1:0 D:$D(^%ZIS(1,"C",%ZISVT)) Q:$S('%E:0,'$D(^%ZIS(1,%E,"TYPE")):0,^("TYPE")="VTRM":1,1:0) S %ZISVT=$E(%ZISVT,1,%ZISI) 40 .D VTLKUP Q:$S('%E:0,'$D(^%ZIS(1,%E,"TYPE")):0,^("TYPE")="VTRM":1,1:0) 41 .S %X=0 F %ZISX=%ZISV,"" Q:%X>0 S %X=0 F S %E=+$O(^%ZIS(1,"CPU",%ZISX_"."_%ZISVT,%X)) S %X=%E Q:%E'>0 I $G(^%ZIS(1,+%E,"TYPE"))="VTRM" Q 42 Q 43 VTLKUP F %ZISX=%ZISV,"" S %E=+$O(^%ZIS(1,"G","SYS."_%ZISX_"."_%ZISVT,0)) Q:%E S %E=+$O(^%ZIS(1,"CPU",%ZISX_"."_%ZISVT,0)) Q:%E 44 Q 45 ; 46 CURRENT N POP,%ZIS,%IS,%E,%H 47 S FF="#",SL=24,BS="*8",RM=80,(SUB,XY)="",%IS=0,%ZISOS=$G(^%ZOSF("OS")),%ZISV=$G(^("VOL")),POP=0 48 D GETHOME K %E,%IS,%ZISI,%ZISOS,%ZISV,%ZISVT,%ZISX Q:POP 49 I $D(^%ZIS(1,%H,"SUBTYPE")) S SUB=+^("SUBTYPE") K %H 50 I $D(SUB),SUB,$D(^%ZIS(2,SUB,1)) S SUB=$S($D(^(0)):$P(^(0),"^"),1:""),FF=$P(^(1),"^",2),SL=$P(^(1),"^",3),BS=$P(^(1),"^",4),XY=$P(^(1),"^",5),RM=+^(1) 51 E S SUB="" 52 I $D(^%ZOSF("RM")) N X S X=RM X ^("RM") K %A 53 Q 54 HOME ;Entry point to establish IO* variables for home device. 55 D CLEAN ;(p363) 56 N X I '$D(^XUTL("XQ",$J,"IO")) S IOP="HOME" D ^%ZIS Q 57 D RESETVAR 58 I '$D(IO("C")),$G(IOM),IO=$I,$D(IO(1,IO)),$D(^%ZOSF("RM")) S X=+IOM X ^("RM") 59 Q 60 ;IO("Q") is checked by many routines after a call to ^%ZISC, so only clean on call to %ZIS. 61 CLEAN ;Cleanup env. Called from %ZISC also. 62 K IO("DOC"),IO("HFSIO"),IO("SPOOL") ;(p366) 63 S (IOPAR,IOUPAR)="" 64 Q 65 ; 66 RESETVAR ;Reset home IO* variables. 67 I '$D(^XUTL("XQ",$J,"IO")) Q 68 N % F %="IO","IOBS","IOF","IOM","ION","IOS","IOSL","IOST","IOST(0)","IOT","IOXY" I $D(^XUTL("XQ",$J,%))#2 S @%=^(%) 69 S POP=0,IO(0)=IO,(IOPAR,IOUPAR)="" 70 Q 71 SAVEVAR ;Save home IO* variables, called from XUS1 72 N % F %="IO","IOBS","IOF","IOM","ION","IOS","IOSL","IOST","IOST(0)","IOT","IOXY" I $D(@%) S ^XUTL("XQ",$J,%)=@% 73 Q 74 ZISLPC Q ;No longer called in Kernel v8. 75 ; 76 HLP1 G EN1^%ZIS7 77 HLP2 N %E,%H,%X,%ZISV,X S %ZISV=$S($D(^%ZOSF("VOL")):^("VOL"),1:"") G EN2^%ZIS7 78 ; 79 REWIND(IO2,IOT,IOPAR) ;Rewind Device 80 N %,X,Y,$ES,$ET S $ET="D REWERR^%ZIS Q 0" 81 S %=$I 82 I '($D(IO2)#2)!'$D(IOT)!'$D(IOPAR) Q 0 83 I "MT^SDP^HFS"'[IOT Q 0 84 S @("Y=$$REW"_IOT_"^%ZIS4(IO2,IOPAR)") 85 U % 86 Q Y 87 REWERR ;Error encountered 88 S IO("ERROR")=$EC 89 S $EC="",$ET="Q:$ES>1 S $EC="""" Q 0" S $EC=",U1," 90 Q 0 91 ; -
WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZIS1.m
r613 r623 1 %ZIS1 ;SFISC/AC,RWF -- DEVICE HANDLER (DEVICE INPUT) ;1/24/08 16:06 2 ;;8.0;KERNEL;**18,49,69,104,112,199,391,440**;JUL 10, 1995;Build 13 3 ;Per VHA Directive 2004-038, this routine should not be modified 4 MAIN ;Called from %ZIS with a GO 5 I '$D(IOP),$D(^%ZIS(1,%E,0)),'$P(^(0),"^",3) S %A=%H,%Z=^(0) D L2^%ZIS2 G EXIT 6 L1 ;Main Loop 7 I '$D(IOP),$D(IO("Q")),POP D AQUE^%ZIS3 K:%=2 IO("Q") S:%=2 %ZISB=$S(%IS'["N":2,1:0) I %=-1 S POP=1 G EXIT 8 S %E=%H,POP=0,%IS=%ZIS ;Reset %IS from %ZIS 9 I %IS'["Q",$D(XQNOGO) S POP=1 W:'$D(IOP) !,$C(7),"OUTPUT IS NEVER ALLOWED FOR THIS OPTION" G EXIT 10 D IOP:$D(IOP),R:'$D(IOP) 11 G EXIT:$D(DTOUT)!$D(DUOUT)!(POP&$D(IOP)),L1:POP&'$D(IOP) 12 D LKUP I %A'>0 S POP=1 D:'$D(DUOUT) MSG1 K DUOUT 13 I '$D(^%ZIS(1,%A,0)) D MSG1 K %ZISIOS S POP=1 14 I POP G EXIT:$D(IOP),L1:'$D(IOP) 15 S %E=%A,%Z=^%ZIS(1,%A,0),%Z1=$G(^(1)) 16 I $D(%ZIS("S")) N Y S Y=%E D XS^ZISX S:'$T POP=1 G G:POP 17 W:'$D(IOP)&($P(%Z,"^",2)'=$I)&($P(%Z1,"^")]"") " ",$P(%Z1,"^") 18 D L2^%ZIS2 ;Call 19 G G L1:POP&'$D(IOP)&'($D(DTOUT)!$D(DUOUT)) ;Didn't get it 20 ; 21 EXIT ; 22 I POP G EX2 ;Did not get the device. 23 ;For type[TRM reset $X & $Y 24 I %ZTYPE["TRM",IO]"",$D(IO(1,IO)) U IO S:'(IO=IO(0)&'$D(IO("S"))&'$D(ZTQUEUED)) $X=0,$Y=0 25 ;Do count of number of times device opened. Field 51. 26 I $L($G(IO)),$D(IO(1,IO))#2,$G(%ZISIOS) D 27 . S $P(^(5),"^",1)=$P($G(^%ZIS(1,%ZISIOS,5)),"^",1)+1 28 I %ZIS["H" S IO(0)=IO,IO("HOME")=%ZISIOS_"^"_IO ;Make home device 29 I '$D(IO("Q")),$D(%ZISLOCK) S ^XUTL("XQ",$J,"lock",%ZISIOS)=%ZISLOCK 30 I $D(IO)#2,IO]"",$D(IO(1,IO))#2,$D(%Z1),$P(%Z1,"^",11) S IO(1,IO,"NOFF")=1 31 EX2 ; 32 I %IS'[0,$G(IO(0))]"" U IO(0) ;Make sure return with home active 33 G SETVAR:'POP!(%IS["T"),KILVAR 34 ; 35 IOP ;Request with IOP set 36 S (%ZISVT,%X)=IOP S:%X'?1.UNP %X=$$UP(%X) I %X'="Q" D SETQ Q 37 S %IS=%IS_%X K IOP W %X D SETQ Q 38 ;Get ready to ask user for device 39 R I %IS["Q",$D(XQNOGO) W !,$C(7),"AT THIS TIME, OUTPUT MUST BE QUEUED" 40 S %A=$S($D(%IS("B")):%IS("B"),1:"HOME") ;Setup default 41 I %IS["P",%A="HOME",$D(^%ZIS(1,%E,99)),$D(^%ZIS(1,+^(99),0)) S %A=$P(^(0),"^",1) 42 RD W !,$S($D(%IS("A")):%IS("A"),1:"DEVICE: ") W:%A]"" %A,"// " D SBR S:%X="" %X=%A S %ZISVT=%X 43 I %X?2"?".E D EN2^%ZIS7 G R 44 I %X?1"?".E D EN1^%ZIS7 G R 45 I $D(DTOUT)!$D(DUOUT)!(%X'?.ANP)!($L($P(%X,";"))>31) S:%IS["T" IO="" S POP=1 Q 46 S:%X'?1.UNP %X=$$UP(%X) D SETQ G R:$T Q 47 SETQ S %Y=$P(%X,";",2,9),%X=$P(%X,";",1) S:$L(";"_%Y,";/")=2 IO("P")=$P(";"_%Y,";/",2) 48 I %IS["Q",%X="Q" S %X=%Y,%ZISVT=$P(%ZISVT,";",2,9),%ZISB=0,IO("Q")=1,%IS("A")="DEVICE: " S:$D(IOP) %Y=$P(%X,";",2,9),%X=$P(%X,";",1) 49 I $T,'$D(IOP) W "UEUE TO PRINT ON" Q ; Return $T value 50 Q 51 LKUP S %ZISMY=$P(%ZISVT,";",2,999),%ZISVT=$P(%ZISVT,";") 52 I %X="H" W:'$D(IOP) "ome" S %X=0 53 I 0[%X!(%X="HOME")!(%X=$I) S %A=%H Q 54 I $E(%ZISVT)="`",$D(IOP) S %A=+$E(%ZISVT,2,999) I $G(^%ZIS(1,%A,0))]"" Q 55 S %A=0 I "P"[%X Q:$D(IOP)&('$D(^%ZIS(1,%E,99))) I $D(^%ZIS(1,%E,99)) S %A=+^(99) Q 56 I %X=" ",$D(DUZ)#2,$D(^DISV(+DUZ,"^%ZIS(1,")) S %A=^("^%ZIS(1,") Q 57 S %A=+$O(^%ZIS(1,"B",%ZISVT,0)) Q:%A>0 ;mixed case lookup 58 I %X'=%ZISVT S %A=+$O(^%ZIS(1,"B",%X,0)) Q:%A>0 ;uppercase lookup 59 D VTLKUP^%ZIS S %A=%E Q:%A>0 ;mixed case lookup 60 I %X'=%ZISVT S %ZISVT=%X D VTLKUP^%ZIS S %A=%E Q:%A>0 ;uppercase lookup 61 N %XX,%YY S %XX=%X D 1^%ZIS5 S %A=+%YY Q 62 SBR K DFOUT,DTOUT,DUOUT R %X:$S($D(DTIME)#2:DTIME,1:300) E W $C(7) S DTOUT=1 Q 63 S:%X="."!(%X="^") DUOUT=1,%X="" Q 64 LC S %X=$$UP(%X) 65 Q 66 LOW(%) Q $TR(%,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz") 67 UP(%) Q $TR(%,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") 68 ; 69 ;Call/Return % = 1 (yes), 2 (no) -1 (^) 70 YN W "? ",$P("Yes// ^No// ",U,%) 71 RYN R %X:$S($D(DTIME):DTIME,$D(%ZISDTIM):%ZISDTIM,1:300) E S DTOUT=1,%X=U W $C(7) 72 S:%X]""!'% %=$A(%X),%=$S(%=89:1,%=121:1,%=78:2,%=110:2,%=94:-1,1:0) 73 I '%,%X'?."?" W $C(7),"??",!?4,"ANSWER 'Yes' OR 'No': " G RYN 74 W:$X>73 ! W $P(" (Yes)^ (No)",U,%) 75 Q 76 MSG1 I '$D(IOP) W ?20,$C(7)," [DEVICE DOES NOT EXIST]" 77 Q 78 SETVAR ;Come here to setup the variables for the selected device 79 S:$D(IO)[0 IO="" G KILVAR:%IS["T"&(IO="") 80 I $G(%Z)="" S ION="Unknown device",POP=1 G KILVAR 81 S:IO'=IO(0)&($D(DUZ)#2) ^DISV(+DUZ,"^%ZIS(1,")=%E 82 S ION=$P(%Z,"^",1),IOM=+%Z91,IOF=$P(%Z91,"^",2),IOSL=$P(%Z91,"^",3),IOBS=$P(%Z91,"^",4),IOXY=$P(%Z91,"^",5) 83 I IOSL>65530 S IOSL=65530 ;Cache rolls $Y at 65535 84 S IOT=%ZTYPE,IOST(0)=%ZISIOST(0),IOST=%ZISIOST,IOPAR=%ZISOPAR,IOUPAR=%ZISUPAR,IOHG=%ZISHG 85 S:IOF="" IOF="#" ;See that IOF has something 86 K IOCPU S:$D(%ZISCPU) IOCPU=%ZISCPU 87 G KIL 88 ; 89 KILVAR ;Come here to restore the calling variables 90 D SYMBOL^%ZISUTL(1,"%ZISOLD") 91 S:'$L($G(IOF)) IOF="#" S:'$D(IOST(0)) IOST(0)=0 92 ;See that all standard variables are defined 93 F %I="IO","ION","IOM","IOBS","IOSL","IOST" S:$D(@%I)[0 @%I="" 94 K IO("HFSIO"),IO("OPEN") I $D(%ZISCPU) S:'$D(IOCPU) IOCPU=%ZISCPU 95 KIL ;Final exit cleanup 96 S:'POP IOS=%ZISIOS I POP K:%IS'["T" %ZISIOS I %IS["T" K IOS S:$D(%ZISIOS) IOS=%ZISIOS 97 S:%IS["T" IO("T")=1 K %ZIS,%IS,%A,%E,%H,%ZISOS,%ZISV,IOP 98 K2 K %I,%X,%Y,%Z,%Z1,%Z91,%Z95,%ZTYPE,%ZTIME 99 K %ZISCHK,%ZISCPU,%ZISI,%ZISR,%ZISVT,%ZISB,%ZISX,ZISI,%ZISHGL,%ZISHP,%ZISIO,%ZISIOS,%ZISIOM 100 K %ZISIOF,%ZISIOSL,%ZISIOBS,%ZISIOST,%ZISIOST(0),%ZISTO,%ZISTP,%ZISHG,%ZISSIO,%ZISOPEN,%ZISOPAR,%ZISUPAR 101 K %ZISMY,%ZISQUIT,%ZISLOCK 102 Q 1 %ZIS1 ;SFISC/AC,RWF -- DEVICE HANDLER (DEVICE INPUT) ;07/07/2005 15:48 2 ;;8.0;KERNEL;**18,49,69,104,112,199,391**;JUL 10, 1995 3 MAIN ;Called from %ZIS with a GO 4 I '$D(IOP),$D(^%ZIS(1,%E,0)),'$P(^(0),"^",3) S %A=%H,%Z=^(0) D L2^%ZIS2 G EXIT 5 L1 ;Main Loop 6 I '$D(IOP),$D(IO("Q")),POP D AQUE^%ZIS3 K:%=2 IO("Q") S:%=2 %ZISB=$S(%IS'["N":2,1:0) I %=-1 S POP=1 G EXIT 7 S %E=%H,POP=0,%IS=%ZIS ;Reset %IS from %ZIS 8 I %IS'["Q",$D(XQNOGO) S POP=1 W:'$D(IOP) !,*7,"OUTPUT IS NEVER ALLOWED FOR THIS OPTION" G EXIT 9 D IOP:$D(IOP),R:'$D(IOP) 10 G EXIT:$D(DTOUT)!$D(DUOUT)!(POP&$D(IOP)),L1:POP&'$D(IOP) 11 D LKUP I %A'>0 S POP=1 D:'$D(DUOUT) MSG1 K DUOUT 12 I POP G EXIT:$D(IOP),L1:'$D(IOP) 13 I '$D(^%ZIS(1,%A,0)) D MSG1 K %ZISIOS S POP=1 14 I POP G EXIT:$D(IOP),L1:'$D(IOP) 15 S %E=%A,%Z=^%ZIS(1,%A,0),%Z1=$G(^(1)) 16 I $D(%ZIS("S")) N Y S Y=%E D XS^ZISX S:'$T POP=1 G G:POP 17 W:'$D(IOP)&($P(%Z,"^",2)'=$I)&($P(%Z1,"^")]"") " ",$P(%Z1,"^") 18 D L2^%ZIS2 19 G G L1:POP&'$D(IOP)&'($D(DTOUT)!$D(DUOUT)) ;Didn't get it 20 ;For type[TRM reset $X & $Y 21 I 'POP,%ZTYPE["TRM",IO]"",$D(IO(1,IO)) U IO S:'(IO=IO(0)&'$D(IO("S"))&'$D(ZTQUEUED)) $X=0,$Y=0 22 ; 23 EXIT I $D(IO)#2,IO]"",$D(IO(1,IO))#2,$D(%Z1),$P(%Z1,"^",11) S IO(1,IO,"NOFF")=1 24 ;Do count of number of times device opened. Field 51. 25 I $L($G(IO)),$D(IO(1,IO))#2,'POP,$G(%ZISIOS) D 26 . S $P(^(5),"^",1)=$P($G(^%ZIS(1,%ZISIOS,5)),"^",1)+1 27 I 'POP,%ZIS["H" S IO(0)=IO,IO("HOME")=%ZISIOS_"^"_IO ;Make home device 28 I %IS'[0,$G(IO(0))]"" U IO(0) ;Make sure return with home active 29 G SETVAR:'POP!(%IS["T"),KILVAR 30 ; 31 IOP ;Request with IOP set 32 S (%ZISVT,%X)=IOP S:%X'?1.UNP %X=$$UP(%X) I %X'="Q" D SETQ Q 33 S %IS=%IS_%X K IOP W %X D SETQ Q 34 ;Get ready to ask user for device 35 R I %IS["Q",$D(XQNOGO) W !,*7,"AT THIS TIME, OUTPUT MUST BE QUEUED" 36 S %A=$S($D(%IS("B")):%IS("B"),1:"HOME") ;Setup default 37 I %IS["P",%A="HOME",$D(^%ZIS(1,%E,99)),$D(^%ZIS(1,+^(99),0)) S %A=$P(^(0),"^",1) 38 RD W !,$S($D(%IS("A")):%IS("A"),1:"DEVICE: ") W:%A]"" %A,"// " D SBR S:%X="" %X=%A S %ZISVT=%X 39 I %X?2"?".E D EN2^%ZIS7 G R 40 I %X?1"?".E D EN1^%ZIS7 G R 41 I $D(DTOUT)!$D(DUOUT)!(%X'?.ANP)!($L($P(%X,";"))>31) S:%IS["T" IO="" S POP=1 Q 42 S:%X'?1.UNP %X=$$UP(%X) D SETQ G R:$T Q 43 SETQ S %Y=$P(%X,";",2,9),%X=$P(%X,";",1) S:$L(";"_%Y,";/")=2 IO("P")=$P(";"_%Y,";/",2) 44 I %IS["Q",%X="Q" S %X=%Y,%ZISVT=$P(%ZISVT,";",2,9),%ZISB=0,IO("Q")=1,%IS("A")="DEVICE: " S:$D(IOP) %Y=$P(%X,";",2,9),%X=$P(%X,";",1) 45 I $T,'$D(IOP) W "UEUE TO PRINT ON" Q ; Return $T value 46 Q 47 LKUP S %ZISMY=$P(%ZISVT,";",2,999),%ZISVT=$P(%ZISVT,";") 48 I %X="H" W:'$D(IOP) "ome" S %X=0 49 I 0[%X!(%X="HOME")!(%X=$I) S %A=%H Q 50 I $E(%ZISVT)="`",$D(IOP) S %A=+$E(%ZISVT,2,999) I $G(^%ZIS(1,%A,0))]"" Q 51 S %A=0 I "P"[%X Q:$D(IOP)&('$D(^%ZIS(1,%E,99))) I $D(^%ZIS(1,%E,99)) S %A=+^(99) Q 52 I %X=" ",$D(DUZ)#2,$D(^DISV(+DUZ,"^%ZIS(1,")) S %A=^("^%ZIS(1,") Q 53 S %A=+$O(^%ZIS(1,"B",%ZISVT,0)) Q:%A>0 ;mixed case lookup 54 I %X'=%ZISVT S %A=+$O(^%ZIS(1,"B",%X,0)) Q:%A>0 ;uppercase lookup 55 D VTLKUP^%ZIS S %A=%E Q:%A>0 ;mixed case lookup 56 I %X'=%ZISVT S %ZISVT=%X D VTLKUP^%ZIS S %A=%E Q:%A>0 ;uppercase lookup 57 N %XX,%YY S %XX=%X D 1^%ZIS5 S %A=+%YY Q 58 SBR K DFOUT,DTOUT,DUOUT R %X:$S($D(DTIME)#2:DTIME,1:300) E W *7 S DTOUT=1 Q 59 S:%X="."!(%X="^") DUOUT=1,%X="" Q 60 LC S %X=$$UP(%X) 61 Q 62 LOW(%) Q $TR(%,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz") 63 UP(%) Q $TR(%,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") 64 YN W "? ",$P("YES// ^NO// ",U,%) 65 RYN R %X:$S($D(DTIME):DTIME,$D(%ZISDTIM):%ZISDTIM,1:300) E S DTOUT=1,%X=U W *7 66 S:%X]""!'% %=$A(%X),%=$S(%=89:1,%=121:1,%=78:2,%=110:2,%=94:-1,1:0) 67 I '%,%X'?."?" W *7,"??",!?4,"ANSWER 'YES' OR 'NO': " G RYN 68 W:$X>73 ! W $P(" (YES)^ (NO)",U,%) Q 69 MSG1 I '$D(IOP) W ?20,*7," [DEVICE DOES NOT EXIST]" 70 Q 71 SETVAR ;Come here to setup the variables for the selected device 72 S:$D(IO)[0 IO="" G KILVAR:%IS["T"&(IO="") 73 I $G(%Z)="" S ION="Unknown device",POP=1 G KILVAR 74 S:IO'=IO(0)&($D(DUZ)#2) ^DISV(+DUZ,"^%ZIS(1,")=%E 75 S ION=$P(%Z,"^",1),IOM=+%Z91,IOF=$P(%Z91,"^",2),IOSL=$P(%Z91,"^",3),IOBS=$P(%Z91,"^",4),IOXY=$P(%Z91,"^",5) 76 I IOSL>65530 S IOSL=65530 ;Cache rolls $Y at 65535 77 S IOT=%ZTYPE,IOST(0)=%ZISIOST(0),IOST=%ZISIOST,IOPAR=%ZISOPAR,IOUPAR=%ZISUPAR,IOHG=%ZISHG 78 S:IOF="" IOF="#" ;See that IOF has something 79 K IOCPU S:$D(%ZISCPU) IOCPU=%ZISCPU G KIL 80 ; 81 KILVAR ;Come here to restore the calling variables 82 D SYMBOL^%ZISUTL(1,"%ZISOLD") 83 S:'$L($G(IOF)) IOF="#" S:'$D(IOST(0)) IOST(0)=0 84 ;See that all standard variables are defined 85 F %I="IO","ION","IOM","IOBS","IOSL","IOST" S:$D(@%I)[0 @%I="" 86 K IO("HFSIO"),IO("OPEN") I $D(%ZISCPU) S:'$D(IOCPU) IOCPU=%ZISCPU 87 KIL ;Final exit cleanup 88 S:'POP IOS=%ZISIOS I POP K:%IS'["T" %ZISIOS I %IS["T" K IOS S:$D(%ZISIOS) IOS=%ZISIOS 89 S:%IS["T" IO("T")=1 K %ZIS,%IS,%A,%E,%H,%ZISOS,%ZISV,IOP 90 K2 K %I,%X,%Y,%Z,%Z1,%Z91,%Z95,%ZTYPE,%ZTIME 91 K %ZISCHK,%ZISCPU,%ZISI,%ZISR,%ZISVT,%ZISB,%ZISX,ZISI,%ZISHGL,%ZISHP,%ZISIO,%ZISIOS,%ZISIOM,%ZISIOF,%ZISIOSL,%ZISIOBS,%ZISIOST,%ZISIOST(0),%ZISTO,%ZISTP,%ZISHG,%ZISSIO,%ZISOPEN,%ZISOPAR,%ZISUPAR 92 K %ZISMY,%ZISQUIT 93 Q -
WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZIS2.m
r613 r623 1 %ZIS2 ;SFISC/AC,RWF -- DEVICE HANDLER (CHECKS) ;1/24/08 16:07 2 ;;8.0;KERNEL;**69,104,112,118,136,241,440**;JUL 10, 1995;Build 13 3 ;Per VHA Directive 2004-038, this routine should not be modified 4 HUNT S:'$D(%ZISHP) %ZISHP=%E,%ZISHGL=0 S %E=0 5 F S %ZISHGL=$O(^%ZIS(1,%ZISHG(0),"HG",%ZISHGL)) Q:%ZISHGL'>0 D Q:%E 6 . N %1,%2 S %1=$G(^%ZIS(1,%ZISHG(0),"HG",+%ZISHGL,0)),%2=$G(^%ZIS(1,+%1,0)) 7 . ;Check that HG device is on same VOL. 8 . I $P(%2,"^",9)=%ZISV!($P(%2,"^",9)="") S %E=+$P(^%ZIS(1,%ZISHG(0),"HG",+%ZISHGL,0),"^") 9 . Q 10 G L2:%ZISHGL>0 S %ZISHPOP=1,%E=%ZISHP 11 ; 12 L2 ;Entry point from %ZIS1 13 I $D(DTOUT)!$D(DUOUT) K %ZISHP,%ZISHPOP Q 14 CHECK ;Get IO check for secondary $I 15 K %ZISCPU N %Z2 16 S POP=0,%Z=^%ZIS(1,%E,0),%Z2=$S(%ZIS("PRI")=1:"",1:$G(^%ZIS(1,%E,2))) ;Get Primary and secondary IO. 17 S IO=$S(%ZIS("PRI")=1:$P(%Z,"^",2),$L($P(%Z2,"^")):$P(%Z2,"^"),1:$P(%Z,"^",2)) ; 18 S:%IS["Q"&'$D(ZTQUEUED)&($P(%Z,"^",12)=1!$D(XQNOGO)) %ZISB=0,IO("Q")=1 ;Forced Queueing 19 I $P(%Z,"^",12)=2 S %IS=$TR(%IS,"Q") I $D(IO("Q")) D Q 20 . I '$D(IOP) W !,"Queuing NOT ALLOWED on this device" 21 . S POP=1 K:$D(IOP) IO("Q") Q 22 S %Z90=$G(^(90)),%Z95=$G(^(95)),%ZTIME=$G(^("TIME")),%ZTYPE=$G(^("TYPE")),%ZISHG=$O(^%ZIS(1,"AHG",%E,0)) 23 I %ZISHG,$D(^%ZIS(1,+%ZISHG,0)) S:'$D(%ZISHG(0)) %ZISHG(0)=+%ZISHG S %ZISHG=$P(^(0),"^",1) 24 E S %ZISHG="" 25 I %ZTYPE="HG" D OTHCPU("HUNT GROUP") G T:$D(%ZISHG(0))!POP 26 I %ZTYPE="RES" S %ZISRL=+$P(%Z1,"^",10) G T 27 VTRM I %ZTYPE="VTRM",'('$D(IO("Q"))&(%A=%H)) W:'$D(IOP)&'$D(%ZISHP) *7," [YOU CAN NOT SELECT A VIRTUAL TERMINAL]" S POP=1 ;Virtual Terminal Check 28 S:%ZTYPE="VTRM"&'$D(IO("Q"))&(%A=%H) IO=$I 29 ; 30 SLAVE I $D(IO("Q")),$P(%Z,"^",2)=0,$P(%Z,"^",8)']"" W:'$D(IOP) *7,!?10," [SLAVE device NOT set up for queuing]" S POP=1 G T 31 OCPU D OTHCPU("DEVICE") 32 ; 33 OOS G T:POP I %Z90,$D(DT)#2,%Z90'>DT S POP=1 ;Out Of Service Check 34 I $T,'$D(IOP),'$D(%ZISHP) W *7," [Out of Service]" ;I 'POP W " ..OK" S %=2,U="^" D YN^%ZIS1 G:%=0 OOS S:%'=1 POP=1 35 ; 36 PTIME G T:POP!(IO=$I)!(IO=0) 37 ;Prohibitted Time Check 38 S %A=$P(%ZTIME,"^") I %ZISB,$L(%A) D I POP,'$D(IOP),'$D(%ZISHP) W *7," [ACCESS PROHIBITED "_%A_"]" ;AT THIS TIME]" 39 . N %C,%L,%H ;%C is current time, %L is lower limit, %H is upper limit 40 . S %C=$P($H,",",2),%C=%C\60#60+(%C\3600*100),%H=$P(%A,"-",2),%L=+%A 41 . I $S(%H'<%L:(%C'>%H&(%C'<%L)),1:(%C'<%L!(%C'>%H))) S POP=1 42 . Q 43 DUZ I 'POP D SEC ;Security Check 44 ; 45 T I POP,$D(%ZISHG(0)),%IS'["D",'$D(%ZISHPOP),%ZISB G HUNT 46 I POP D HGBSY:$D(%ZISHPOP) ;G T2:%IS["T" 47 ; 48 TMPVAR K IO("S") S %ZISIOS=%E S:IO=0 IO=$I,IO("S")=%H 49 S %ZISOPAR=$$IOPAR(%E,"IOPAR") 50 S %ZISUPAR=$$IOPAR(%E,"IOUPAR"),%ZISTO=+$P(%ZTIME,"^",2) 51 I $D(IO("S")) D I POP Q 52 . S IO=$S(%IS["S":$P($G(^%ZIS(1,+$P(%Z,"^",8),0)),"^",2),1:IO) 53 . I %IS["S",IO]"" S %H=+$P(%Z,"^",8),IO("S")=%H,IO(0)=IO 54 . S IO("S")=$S($G(^XUTL("XQ",$J,"IOST(0)")):^("IOST(0)"),1:$G(^%ZIS(1,%H,"SUBTYPE"))) 55 . S:IO="" POP=1 56 . Q 57 S %A=+$G(^%ZIS(1,%E,"SUBTYPE")),%ZISTP=0 ;%A is pointer to subtype 58 I %E=%H,%ZTYPE["TRM" D I 1 59 . I $D(^XUTL("XQ",$J,"IOST(0)")) D ;Use home 60 . . S %A=+^XUTL("XQ",$J,"IOST(0)"),%Z91="",%ZISTP=1 61 . . F %ZISI="IOM","IOF","IOSL","IOBS","IOXY" S %Z91=%Z91_$G(^XUTL("XQ",$J,%ZISI))_"^" 62 . E S %=$$LNPRTSUB^%ZISUTL I %>0 S %A=%,%Z91="" 63 E S %Z91=$P($G(^%ZIS(2,%A,1)),"^",1,4),$P(%Z91,"^",5)=$G(^("XY")) 64 ;I $D(%Z91),%Z91'?1.4"^" ;$P(%Z91,"^")]"",$P(%Z91,"^",2)]"",$P(%Z91,"^",3),$P(%Z91,"^",4)]"" 65 D ST^%ZIS3(%ZISTP) S:%IS["U" USIO=$P(%Z91,"^",1,4) 66 T2 I POP S:%IS'["T" IO="" Q 67 G ^%ZIS3:"^MTRM^VTRM^TRM^SPL^MT^SDP^HFS^RES^OTH^BAR^HG^IMPC^CHAN^"[("^"_%ZTYPE_"^") ;Jump to next part 68 S POP=1 Q 69 ; 70 HGBSY S POP=1 S:%IS'["T" IO="" K %ZISHP,%ZISHPOP Q:$D(IOP) 71 W:$X>38 !,?5 W *7," All devices in hunt group "_%ZISHG_" are busy!" Q 72 ; 73 OTHCPU(%1) ;%1 should be either DEVICE or HUNT GROUP 74 N %2,X,Y,%ZISMSG S %ZISMSG=0 75 F %2="CPU","VOLUME SET" D 76 .I %2="VOLUME SET" S X=$P($P(%Z,"^",9),":"),Y=%ZISV 77 .E D GETENV^%ZOSV S X=$P($P(%Z,"^",9),":",2),Y=$P($P(Y,"^",4),":",2) 78 .I X=Y!(X="") Q:%1="DEVICE" D Q ;Other Vol Set/Cpu Check 79 ..S %ZISHG(0)=%E,%ZISHG=$P(%Z,"^") 80 ..I %ZISB S POP=1 81 ..E S IO=" " 82 .I %2="VOLUME SET" S $P(%ZISCPU,":")=X 83 .E S $P(%ZISCPU,":",2)=X 84 .I %1="HUNT GROUP" K %ZISHG(0) 85 .I %IS["Q" S IO("Q")=1,%ZISB=0 S:%1="HUNT GROUP" IO=" " 86 .E I %ZISB&(%ZTYPE="TRM"&($D(%ZISHG(0))&(%IS'["D"))) S POP=1 87 .E W:'$D(IOP)&'%ZISMSG *7," ["_%1_" is on another "_%2_" ('"_X_"')]",! S POP=1,%ZISMSG=1 88 Q 89 IOPAR(%DA,%N) ;Return I/O parameters 90 Q $S($G(%ZIS(%N))]"":%ZIS(%N),1:$G(^%ZIS(1,%DA,%N))) 91 ; 92 SEC I %Z95]"" S %X=$G(DUZ(0)) I %X'="@" S POP=1 F %A=1:1:$L(%X) I %Z95[$E(%X,%A) S POP=0 Q 93 I POP,'$D(IOP),'$D(%ZISHP) W *7," [Access Prohibited]" 94 Q 1 %ZIS2 ;SFISC/AC,RWF -- DEVICE HANDLER (CHECKS) ;06/12/2002 15:41 2 ;;8.0;KERNEL;**69,104,112,118,136,241**;JUL 10, 1995 3 HUNT S:'$D(%ZISHP) %ZISHP=%E,%ZISHGL=0 S %E=0 4 F S %ZISHGL=$O(^%ZIS(1,%ZISHG(0),"HG",%ZISHGL)) Q:%ZISHGL'>0 D Q:%E 5 . N %1,%2 S %1=$G(^%ZIS(1,%ZISHG(0),"HG",+%ZISHGL,0)),%2=$G(^%ZIS(1,+%1,0)) 6 . ;Check that HG device is on same VOL. 7 . I $P(%2,"^",9)=%ZISV!($P(%2,"^",9)="") S %E=+$P(^%ZIS(1,%ZISHG(0),"HG",+%ZISHGL,0),"^") 8 . Q 9 G L2:%ZISHGL>0 S %ZISHPOP=1,%E=%ZISHP 10 ; 11 L2 ;Entry point from %ZIS1 12 I $D(DTOUT)!$D(DUOUT) K %ZISHP,%ZISHPOP Q 13 CHECK K %ZISCPU S POP=0,%Z=^%ZIS(1,%E,0),IO=$P(%Z,"^",2) 14 S:%IS["Q"&'$D(ZTQUEUED)&($P(%Z,"^",12)=1!$D(XQNOGO)) %ZISB=0,IO("Q")=1 ;Forced Queueing 15 I $P(%Z,"^",12)=2 S %IS=$TR(%IS,"Q") I $D(IO("Q")) D Q 16 . I '$D(IOP) W !,"Queuing NOT ALLOWED on this device" 17 . S POP=1 K:$D(IOP) IO("Q") Q 18 S %Z90=$G(^(90)),%Z95=$G(^(95)),%ZTIME=$G(^("TIME")),%ZTYPE=$G(^("TYPE")),%ZISHG=$O(^%ZIS(1,"AHG",%E,0)) 19 I %ZISHG,$D(^%ZIS(1,+%ZISHG,0)) S:'$D(%ZISHG(0)) %ZISHG(0)=+%ZISHG S %ZISHG=$P(^(0),"^",1) 20 E S %ZISHG="" 21 I %ZTYPE="HG" D OTHCPU("HUNT GROUP") G T:$D(%ZISHG(0))!POP 22 I %ZTYPE="RES" S %ZISRL=+$P(%Z1,"^",10) G T 23 VTRM I %ZTYPE="VTRM",'('$D(IO("Q"))&(%A=%H)) W:'$D(IOP)&'$D(%ZISHP) *7," [YOU CAN NOT SELECT A VIRTUAL TERMINAL]" S POP=1 ;Virtual Terminal Check 24 S:%ZTYPE="VTRM"&'$D(IO("Q"))&(%A=%H) IO=$I 25 ; 26 SLAVE I $D(IO("Q")),$P(%Z,"^",2)=0,$P(%Z,"^",8)']"" W:'$D(IOP) *7,!?10," [SLAVE device NOT set up for queuing]" S POP=1 G T 27 OCPU D OTHCPU("DEVICE") 28 ; 29 OOS G T:POP I %Z90,$D(DT)#2,%Z90'>DT S POP=1 ;Out Of Service Check 30 I $T,'$D(IOP),'$D(%ZISHP) W *7," [Out of Service]" ;I 'POP W " ..OK" S %=2,U="^" D YN^%ZIS1 G:%=0 OOS S:%'=1 POP=1 31 ; 32 PTIME G T:POP!(IO=$I)!(IO=0) 33 ;Prohibitted Time Check 34 S %A=$P(%ZTIME,"^") I %ZISB,$L(%A) D I POP,'$D(IOP),'$D(%ZISHP) W *7," [ACCESS PROHIBITED "_%A_"]" ;AT THIS TIME]" 35 . N %C,%L,%H ;%C is current time, %L is lower limit, %H is upper limit 36 . S %C=$P($H,",",2),%C=%C\60#60+(%C\3600*100),%H=$P(%A,"-",2),%L=+%A 37 . I $S(%H'<%L:(%C'>%H&(%C'<%L)),1:(%C'<%L!(%C'>%H))) S POP=1 38 . Q 39 DUZ I 'POP D SEC ;Security Check 40 ; 41 T I POP,$D(%ZISHG(0)),%IS'["D",'$D(%ZISHPOP),%ZISB G HUNT 42 I POP D HGBSY:$D(%ZISHPOP) ;G T2:%IS["T" 43 ; 44 TMPVAR K IO("S") S %ZISIOS=%E S:IO=0 IO=$I,IO("S")=%H 45 S %ZISOPAR=$$IOPAR(%E,"IOPAR") 46 S %ZISUPAR=$$IOPAR(%E,"IOUPAR"),%ZISTO=+$P(%ZTIME,"^",2) 47 I $D(IO("S")) D I POP Q 48 . S IO=$S(%IS["S":$P($G(^%ZIS(1,+$P(%Z,"^",8),0)),"^",2),1:IO) 49 . I %IS["S",IO]"" S %H=+$P(%Z,"^",8),IO("S")=%H,IO(0)=IO 50 . S IO("S")=$S($G(^XUTL("XQ",$J,"IOST(0)")):^("IOST(0)"),1:$G(^%ZIS(1,%H,"SUBTYPE"))) 51 . S:IO="" POP=1 52 . Q 53 S %A=+$G(^%ZIS(1,%E,"SUBTYPE")),%ZISTP=0 ;%A is pointer to subtype 54 I %E=%H,%ZTYPE["TRM" D I 1 55 . I $D(^XUTL("XQ",$J,"IOST(0)")) D ;Use home 56 . . S %A=+^XUTL("XQ",$J,"IOST(0)"),%Z91="",%ZISTP=1 57 . . F %ZISI="IOM","IOF","IOSL","IOBS","IOXY" S %Z91=%Z91_$G(^XUTL("XQ",$J,%ZISI))_"^" 58 . E S %=$$LNPRTSUB^%ZISUTL I %>0 S %A=%,%Z91="" 59 E S %Z91=$P($G(^%ZIS(2,%A,1)),"^",1,4),$P(%Z91,"^",5)=$G(^("XY")) 60 ;I $D(%Z91),%Z91'?1.4"^" ;$P(%Z91,"^")]"",$P(%Z91,"^",2)]"",$P(%Z91,"^",3),$P(%Z91,"^",4)]"" 61 D ST^%ZIS3(%ZISTP) S:%IS["U" USIO=$P(%Z91,"^",1,4) 62 T2 I POP S:%IS'["T" IO="" Q 63 G ^%ZIS3:"^MTRM^VTRM^TRM^SPL^MT^SDP^HFS^RES^OTH^BAR^HG^IMPC^CHAN^"[("^"_%ZTYPE_"^") ;Jump to next part 64 S POP=1 Q 65 ; 66 HGBSY S POP=1 S:%IS'["T" IO="" K %ZISHP,%ZISHPOP Q:$D(IOP) 67 W:$X>38 !,?5 W *7," All devices in hunt group "_%ZISHG_" are busy!" Q 68 ; 69 OTHCPU(%1) ;%1 should be either DEVICE or HUNT GROUP 70 N %2,X,Y,%ZISMSG S %ZISMSG=0 71 F %2="CPU","VOLUME SET" D 72 .I %2="VOLUME SET" S X=$P($P(%Z,"^",9),":"),Y=%ZISV 73 .E D GETENV^%ZOSV S X=$P($P(%Z,"^",9),":",2),Y=$P($P(Y,"^",4),":",2) 74 .I X=Y!(X="") Q:%1="DEVICE" D Q ;Other Vol Set/Cpu Check 75 ..S %ZISHG(0)=%E,%ZISHG=$P(%Z,"^") 76 ..I %ZISB S POP=1 77 ..E S IO=" " 78 .I %2="VOLUME SET" S $P(%ZISCPU,":")=X 79 .E S $P(%ZISCPU,":",2)=X 80 .I %1="HUNT GROUP" K %ZISHG(0) 81 .I %IS["Q" S IO("Q")=1,%ZISB=0 S:%1="HUNT GROUP" IO=" " 82 .E I %ZISB&(%ZTYPE="TRM"&($D(%ZISHG(0))&(%IS'["D"))) S POP=1 83 .E W:'$D(IOP)&'%ZISMSG *7," ["_%1_" is on another "_%2_" ('"_X_"')]",! S POP=1,%ZISMSG=1 84 Q 85 IOPAR(%DA,%N) ;Return I/O parameters 86 Q $S($G(%ZIS(%N))]"":%ZIS(%N),1:$G(^%ZIS(1,%DA,%N))) 87 ; 88 SEC I %Z95]"" S %X=$G(DUZ(0)) I %X'="@" S POP=1 F %A=1:1:$L(%X) I %Z95[$E(%X,%A) S POP=0 Q 89 I POP,'$D(IOP),'$D(%ZISHP) W *7," [Access Prohibited]" 90 Q -
WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZIS3.m
r613 r623 1 %ZIS3 ;SFISC/AC,RWF -- DEVICE HANDLER(DEVICE TYPES & PARAMETERS) ;1/24/08 13:18 2 ;;8.0;KERNEL;**18,36,69,104,391,440**;JUL 10, 1995;Build 13 3 ;Per VHA Directive 2004-038, this routine should not be modified 4 ;Call with a Go from ^%ZIS2 5 I %ZIS'["T",$G(^%ZIS(1,+%E,"POX"))]"" D XPOX^ZISX(%E) ;Pre-Open 6 I $D(%ZISQUIT) S POP=1 K %ZISQUIT 7 S %ZISCHK=1 8 ;I 'POP&(%ZISB)&(%ZTYPE'="RES")&(%ZTYPE'="OTH")&(%ZTYPE'="SDP")&(IO'["::") D DEVOK 9 ;See if need to lock. 10 K %ZISLOCK 11 I %ZIS'["T",+$G(^%ZIS(1,+%E,"GBL")) S %ZISLOCK=$NA(^%ZIS("lock",IO)) 12 ; 13 I 'POP G TRM:(%ZTYPE["TRM"),@(%ZTYPE_"^%ZIS6") ;Jump to next part 14 ; 15 Q ;%ZIS6 Returns here 16 ;See if need to un-lock. 17 I $D(%ZISUOUT) K %ZISUOUT,%ZISHP,%ZISHPOP Q 18 I $D(%ZISHPOP)&$S(IO="":1,1:'$D(IO(1,IO))) D HGBSY^%ZIS2 Q 19 I POP S:%ZIS'["T" IO="" I $D(%ZISHG(0)),%ZIS'["D",'$D(%ZISHPOP) G HUNT^%ZIS2 20 Q ;Return to %ZIS1 21 ; 22 VTRM ;Virtual terminal type 23 TRM ;D OPEN^%ZIS4:'POP&(%ZISB&(%ZIS'["T")),MARGN:'POP,SETPAR:'POP ;Terminal type 24 D MARGN:'POP,SETPAR:'POP ;Terminal type// TEST CHANGE 25 I 'POP,%ZIS'["T",%ZISB=1,'$D(IOP),IO'=IO(0),'$D(IO("Q")),%ZIS["Q" D AQUE 26 W:'$D(IOP) ! 27 I '$D(IO("Q")),'POP,%ZISB,%ZIS'["T" D O^%ZIS4 28 G Q 29 DEVOK N X,Y,X1 ;Not sure this is needed 30 S X=IO,X1=%ZTYPE 31 D DEVOK^%ZOSV I Y=-99!(Y=0)!(Y=$J) Q 32 I Y>0 S POP=1 W:'$D(IOP)&('$D(%ZISHG(0))!(%IS["D")) !,$C(7),"[Device Unavailable]" Q 33 I Y=-1 S IO="",POP=1 W:'$D(IOP)&('$D(ZISHG(0))!(%IS["D")) !,$C(7),"[Device does not Exist or Unavailable]" Q 34 Q 35 ; 36 MARGN ;Get the margin and page length 37 S %A=$P(%Y,";",1) 38 I %A?1A.ANP D SUBIEN(.%A,1) I $D(^%ZIS(2,%A,1)) K %Z91 D ST(1) S %Y=$P(%Y,";",2,9),%ZISMY=$P(%ZISMY,";",2,9) G MARGN 39 I %A>3 S $P(%Z91,"^")=$S(%A>255:255,1:+%A) 40 I $P(%Y,";",2) S $P(%Z91,"^",3)=+$S($P(%Y,";",2)>65530:65530,1:$P(%Y,";",2)) ;Cache fix for $Y#65535 wrap 41 ; 42 ALTP I '$D(IO("P")) Q:%A>3 G ASKMAR:%ZTYPE["TRM" Q 43 S %X=$F(IO("P"),"M") I %X S %A=+$E(IO("P"),%X,99),$P(%Z91,"^")=$S(%A>255:255,1:%A) 44 S %X=$F(IO("P"),"L") I %X S $P(%Z91,"^",3)=+$E(IO("P"),%X,99) 45 Q:%A>3!(%ZTYPE'["TRM") 46 ASKMAR I %IS["M",'$D(IOP),$S(%E=%H:+$P(%Z,"^",3),1:1),$P(%Z,"^",4) W " Right Margin: " W:$P(%Z91,"^")]"" +%Z91,"// " 47 E Q 48 D SBR^%ZIS1 I '$D(DTOUT)&'$D(DUOUT) S:%X=""&($P(%Z91,"^")]"") %X=+%Z91 G ASKMAR:%X'?1.N S $P(%Z91,"^")=$S(%X>255:255,1:%X) Q 49 S POP=1 I %ZISB&(%ZTYPE["TRM")&(IO'=IO(0)) C IO K IO(1,IO) Q 50 Q 51 SETPAR S:$L(%ZISOPAR)&($E(%ZISOPAR)'="(") %ZISOPAR="("_%ZISOPAR_")" 52 Q 53 AQUE ;Ask about Queueing 54 W ! S %=$S($D(IO("Q")):1,1:2),U="^",%ZISDTIM=60 55 I $D(IO("Q")) W !,"Previously, you have selected queueing." 56 W !,"Do you "_$S($D(IO("Q")):"STILL ",1:"")_"want your output QUEUED" 57 D YN^%ZIS1 K %ZISDTIM G AQUE:%=0 Q:$D(IO("Q")) 58 I %=-1 S POP=1,%ZISHPOP=1,%ZISUOUT=1 C IO K IO(1,IO) Q 59 I %=1 S IO("Q")=1 C IO K IO(1,IO) Q 60 ;I %=2 K IO("Q") 61 Q 62 ST(%ZISTP) ; 63 S %ZISIOST(0)=%A,%ZISIOST=$P($G(^%ZIS(2,%A,0)),"^") 64 S:'$D(%Z91) %Z91=$P($G(^%ZIS(2,%A,1),"132^#^60^$C(8)"),"^",1,4),$P(%Z91,"^",5)=$G(^("XY")) 65 Q:%ZISTP 66 STP N %B ;%E is a pointer to the Device file 67 S %B=$G(^%ZIS(1,%E,91)) 68 S:$P(%B,"^")]"" $P(%Z91,"^")=+%B S:$P(%B,"^",3)]"" $P(%Z91,"^",3)=$P(%B,"^",3) ;S $P(%Z91,"^",5)=$G(^%ZIS(2,%ZISIOST(0),"XY")) 69 Q 70 SUBIEN(%1,%) ;Return Subtype ien. %1 is call by Ref. 71 N %XX,%YY 72 I $D(^%ZIS(2,"B",%1))>9 S %1=+$O(^%ZIS(2,"B",%1,0)) Q 73 I '$G(%) S X="" Q 74 S %XX=%1 D 2^%ZIS5 S %1=+%YY 75 Q 76 SUBTYPE(%A) ;Called from %ZISH 77 N %ZISIOST,%Z91 78 S:$G(%A)="" %A="P-OTHER" 79 D SUBIEN(.%A),ST(1) 80 S IOM=$P(%Z91,U,1),IOF=$P(%Z91,U,2),IOSL=$P(%Z91,U,3),IOST=%ZISIOST,IOST(0)=%ZISIOST(0),IOBS="$C(8)" 81 S:IOST="" IOST="P-OTHER",IOST(0)=0 82 Q 1 %ZIS3 ;SFISC/AC,RWF -- DEVICE HANDLER(DEVICE TYPES & PARAMETERS) ;10/06/2005 13:23 2 ;;8.0;KERNEL;**18,36,69,104,391**;JUL 10, 1995 3 I %ZIS'["T",$G(^%ZIS(1,+%E,"POX"))]"" D XPOX^ZISX(%E) 4 I $D(%ZISQUIT) S POP=1 K %ZISQUIT 5 S %ZISCHK=1 6 I 'POP&(%ZISB)&(%ZTYPE'="RES")&(%ZTYPE'="OTH")&(%ZTYPE'="SDP")&(IO'["::") D DEVOK 7 G Q:POP 8 G @%ZTYPE:(%ZTYPE["TRM"),@(%ZTYPE_"^%ZIS6") ;Jump to next part 9 ; 10 Q I $D(%ZISUOUT) K %ZISUOUT,%ZISHP,%ZISHPOP Q 11 I $D(%ZISHPOP)&$S(IO="":1,1:'$D(IO(1,IO))) D HGBSY^%ZIS2 Q 12 I POP S:%IS'["T" IO="" I $D(%ZISHG(0)),%IS'["D",'$D(%ZISHPOP) G HUNT^%ZIS2 13 Q 14 VTRM ;Virtual terminal type 15 TRM D OPEN^%ZIS4:'POP&(%ZISB&(%IS'["T")),MARGN:'POP,SETPAR:'POP ;Terminal type 16 I 'POP,%IS'["T",%ZISB=1,'$D(IOP),IO'=IO(0),'$D(IO("Q")),%IS["Q" D AQUE 17 W:'$D(IOP) ! I '$D(IO("Q")) D O^%ZIS4:'POP&(%ZISB&(%IS'["T")) 18 G Q 19 DEVOK N X,Y,X1 20 S X=IO,X1=%ZTYPE 21 D DEVOK^%ZOSV I Y=-99!(Y=0)!(Y=$J) Q 22 I Y>0 S POP=1 W:'$D(IOP)&('$D(%ZISHG(0))!(%IS["D")) !,*7,"[Device Unavailable]" Q 23 I Y=-1 S IO="",POP=1 W:'$D(IOP)&('$D(ZISHG(0))!(%IS["D")) !,*7,"[Device does not Exist or Unavailable]" Q 24 Q 25 ; 26 MARGN ;Get the margin and page length 27 S %A=$P(%Y,";",1) 28 I %A?1A.ANP D SUBIEN(.%A,1) I $D(^%ZIS(2,%A,1)) K %Z91 D ST(1) S %Y=$P(%Y,";",2,9),%ZISMY=$P(%ZISMY,";",2,9) G MARGN 29 I %A>3 S $P(%Z91,"^")=$S(%A>255:255,1:+%A) 30 I $P(%Y,";",2) S $P(%Z91,"^",3)=+$S($P(%Y,";",2)>65530:65530,1:$P(%Y,";",2)) ;Cache fix for $Y#65535 wrap 31 ; 32 ALTP I '$D(IO("P")) Q:%A>3 G ASKMAR:%ZTYPE["TRM" Q 33 S %X=$F(IO("P"),"M") I %X S %A=+$E(IO("P"),%X,99),$P(%Z91,"^")=$S(%A>255:255,1:%A) 34 S %X=$F(IO("P"),"L") I %X S $P(%Z91,"^",3)=+$E(IO("P"),%X,99) 35 Q:%A>3!(%ZTYPE'["TRM") 36 ASKMAR I %IS["M",'$D(IOP),$S(%E=%H:+$P(%Z,"^",3),1:1),$P(%Z,"^",4) W " Right Margin: " W:$P(%Z91,"^")]"" +%Z91,"// " 37 E Q 38 D SBR^%ZIS1 I '$D(DTOUT)&'$D(DUOUT) S:%X=""&($P(%Z91,"^")]"") %X=+%Z91 G ASKMAR:%X'?1.N S $P(%Z91,"^")=$S(%X>255:255,1:%X) Q 39 S POP=1 I %ZISB&(%ZTYPE["TRM")&(IO'=IO(0)) C IO K IO(1,IO) Q 40 Q 41 SETPAR S:%ZISOPAR]""&($A(%ZISOPAR)-40) %ZISOPAR="("_%ZISOPAR_")" 42 Q 43 AQUE W ! S %=$S($D(IO("Q")):1,1:2),U="^",%ZISDTIM=60 44 I $D(IO("Q")) W !,"Previously, you have selected queueing." 45 W !,"Do you "_$S($D(IO("Q")):"STILL ",1:"")_"want your output QUEUED" 46 D YN^%ZIS1 K %ZISDTIM G AQUE:%=0 Q:$D(IO("Q")) 47 I %=-1 S POP=1,%ZISHPOP=1,%ZISUOUT=1 C IO K IO(1,IO) Q 48 I %=1 S IO("Q")=1 C IO K IO(1,IO) Q 49 Q 50 ST(%ZISTP) ; 51 S %ZISIOST(0)=%A,%ZISIOST=$P($G(^%ZIS(2,%A,0)),"^") 52 S:'$D(%Z91) %Z91=$P($G(^%ZIS(2,%A,1),"132^#^60^$C(8)"),"^",1,4),$P(%Z91,"^",5)=$G(^("XY")) 53 Q:%ZISTP 54 STP N %B ;%E is a pointer to the Device file 55 S %B=$G(^%ZIS(1,%E,91)) 56 S:$P(%B,"^")]"" $P(%Z91,"^")=+%B S:$P(%B,"^",3)]"" $P(%Z91,"^",3)=$P(%B,"^",3) ;S $P(%Z91,"^",5)=$G(^%ZIS(2,%ZISIOST(0),"XY")) 57 Q 58 SUBIEN(%1,%) ;Return Subtype ien. %1 is call by Ref. 59 N %XX,%YY 60 I $D(^%ZIS(2,"B",%1))>9 S %1=+$O(^%ZIS(2,"B",%1,0)) Q 61 I '$G(%) S X="" Q 62 S %XX=%1 D 2^%ZIS5 S %1=+%YY 63 Q 64 SUBTYPE(%A) ;Called from %ZISH 65 N %ZISIOST,%Z91 66 S:$G(%A)="" %A="P-OTHER" 67 D SUBIEN(.%A),ST(1) 68 S IOM=$P(%Z91,U,1),IOF=$P(%Z91,U,2),IOSL=$P(%Z91,U,3),IOST=%ZISIOST,IOST(0)=%ZISIOST(0),IOBS="$C(8)" 69 S:IOST="" IOST="P-OTHER",IOST(0)=0 70 Q 71 -
WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZIS4GTM.m
r613 r623 1 %ZIS4 ;ISF/RWF,DW - DEVICE HANDLER SPECIFIC CODE (GT.M for Unix/VMS) ;1/24/08 16:08 2 ;;8.0;KERNEL;**275,425,440**;Jul 10, 1995;Build 13 3 ;Per VHA Directive 2004-038, this routine should not be modified 4 OPEN ;From %ZIS3 for TRM 5 G OPN2:$D(IO(1,IO)) 6 S POP=0 D OP1 G NOPEN:'$D(IO(1,IO)) 7 OPN2 ; 8 I $D(%ZISHP),'$D(IOP) W !,*7," Routing to device "_$P(^%ZIS(1,%E,0),"^",1)_$S($D(^(1)):" "_$P(^(1),"^",1)_" ",1:"") 9 Q 10 NOPEN I %IS'["D",$D(%ZISHP)!(%ZISHG]"") S POP=1 Q 11 I '$D(IOP) W *7," [BUSY]" W " ... RETRY" S %=2,U="^" D YN^%ZIS1 G OPEN:%=1 12 S POP=1 Q 13 Q 14 ;Why no open paraneters??? 15 OP1 N $ET S $ET="G OPNERR^%ZIS4" 16 I $D(%ZISLOCK) L +@%ZISLOCK:5 E S POP=1 Q 17 O IO::%ZISTO S:$T IO(1,IO)="" S:'$T POP=1 18 Q 19 OPNERR ;Open Error 20 S POP=1,IO("LASTERR")=$G(IO("ERROR")),IO("ERROR")=$$EC^%ZOSV,$EC="" 21 Q 22 ; 23 O ;From %ZIS6 for all types. 24 D:%IS["L" ZIO 25 I $D(IO("S")),$D(^%ZIS(2,IO("S"),10)),^(10)]"" U IO(0) D X10^ZISX ;Open Printer Port 26 OPAR I $D(IOP),%ZTYPE="HFS",$D(%IS("HFSIO")),$D(%IS("IOPAR")),%IS("HFSIO")]"" S IO=%IS("HFSIO"),%ZISOPAR=%IS("IOPAR") 27 I %ZTYPE="CHAN" D TCPIP Q:POP G OXECUTE^%ZIS6 28 S %A=%ZISOPAR_$S(%ZISOPAR["):":"",1:":"_%ZISTO) 29 N % S %(IO)="",%=$P($P($NA(%(IO)),"(",2),")") 30 S %A=%_$E(":",%A]"")_%A 31 D O1 I POP D Q 32 .I %ZTYPE="HFS",'$D(IOP),$G(IO("ERROR"))["file not found" W !,?5,*7,"[File Not Found]" Q 33 .W:'$D(IOP) !,?5,*7,"[DEVICE IS BUSY]" Q 34 ;S IO(1,IO)="" U IO S:'(IO=IO(0)&'$D(IO("S"))&'$D(ZTQUEUED)) $X=0,$Y=0 I %ZTYPE["TRM" U IO:(WIDTH=+%Z91) 35 U IO S $X=0,$Y=0 I %ZTYPE["TRM" U IO:(WIDTH=+%Z91) 36 I %ZISUPAR]"" S %A1=""""_IO_""":"_%ZISUPAR U @%A1 37 ;U:%IS'[0 IO(0) 38 G OXECUTE^%ZIS6 39 ; 40 O1 N $ES,$ET S $ET="G OPNERR^%ZIS4" 41 I $D(%ZISLOCK) L +@%ZISLOCK:5 E S POP=1 Q 42 O @%A S:'$T&(%A?.E1":".N) POP=1 S:'POP IO(1,IO)="" 43 S IO("ERROR")="" Q 44 ; 45 ;Need to find out how to get IP address 46 ZIO N %,%1 S (%,%1)=$ZIO 47 I $ZV["VMS",%["_TNA" D 48 . S (%,%1)=$ZGETDVI($I,"TT_ACCPORNAM") 49 . S %=$S(%["Host:":$P($P(%,"Host: ",2)," ")_":"_$P(%,"Port: ",2),1:%) S:%[" " %=$TR(%," ") 50 I $ZV'["VMS" D 51 . S (%,%1)=$ZTRNLNM("REMOTEHOST") S:$L(%) %1="Host:"_% S:'$L(%) %=$ZIO 52 S IO("ZIO")=% S:(%1["Host:")&'$D(IO("IP")) IO("IP")=$P(%,":") 53 Q 54 ; 55 TCPIP ;For TCP/IP devices, should use ^%ZISTCP 56 N %S 57 S %ZISTO=$G(%ZISTO,3) 58 S %A="IO:"_$S($E(%ZISOPAR)="(":"",1:"(")_%ZISOPAR_$S($E(%ZISOPAR,$L(%ZISOPAR))=")":"",1:")")_":%ZISTO:""SOCKET""" 59 ;U $P W !,"%A=",%A 60 O @%A I '$T S POP=1 Q ;D O1 ;Do the open. 61 U IO:(WIDTH=512:NOWRAP:EXCEPT="G OPNERR^%ZIS4") S %S=$KEY 62 U $P ;W !,"$KEY=",%S 63 Q 64 ; 65 SPOOL ;%ZDA=pointer to ^XMB(3.51, %ZFN=spool file name. 66 I $D(ZISDA) W:'$D(IOP) !?5,*7,"You may not Spool the printing of a Spool document" G N 67 I $D(DUZ)[0 W:'$D(IOP) !,"Must be a valid user." G N 68 R S %ZY=-1 D NEWDOC^ZISPL1 G N:%ZY'>0 69 S %ZDA=+%ZY,%ZFN=$P(%ZY(0),U,2),IO("DOC")=$P(%ZY(0),U,1) G OK:$D(IO("Q")) 70 G:'%ZISB OK I '$P(%ZY,"^",3),$L(%ZFN) O %ZFN:(append:nowrap):2 G DOC 71 S %ZFN=IO_"SPOOL_no_"_%ZDA_".TMP" D SPL2 G:%ZFN']"" N S $P(^XMB(3.51,%ZDA,0),U,2)=%ZFN,^XMB(3.51,"C",%ZFN,%ZDA)="" 72 DOC S IO=%ZFN,IO("SPOOL")=%ZDA,^XUTL("XQ",$J,"SPOOL")=%ZDA,IOF="#" 73 I $D(^%ZIS(1,%ZISIOS,1)),$P(^(1),"^",8),$O(^("SPL",0)) S ^XUTL("XQ",$J,"ADSPL")=%ZISIOS,ZISPLAD=%ZISIOS 74 OK K %ZDA,%ZFN Q 75 N K %ZDA,%ZFN,IO("DOC") S POP=1 Q 76 ; 77 SPL2 ;Open for write 78 O %ZFN:(newversion:noreadonly:nowrap:exception="G SPL4"):2 G:$ZA<0 SPL4 S IO(1,%ZFN)="" Q 79 ; 80 SPL3 ;Open for Read 81 O %ZFN:(readonly:exception="G SPL4"):2 S:'$T ZISPLQ=1 G:'$T SPL4 S IO(1,%ZFN)="" Q 82 SPL4 W:'$D(IOP)&'$D(ZTQUEUED) !?5,*7,"Couldn't open the spool file." S %ZFN="" Q 83 ; 84 CLOSE ;Close out the spool 85 N %,%1,%Z1,%ZFN,%ZS,%ZDA,XS,%Y,%X 86 I $L(IO) C IO K IO(1,IO) 87 D FILE^ZISPL1 I %ZDA'>0 K ZISPLAD Q 88 S %ZFN=$P(%ZS,"^",2) D SPL3 Q:%ZFN']"" S %ZCR=$C(13),%Y="" 89 S %Z1=+$G(^XTV(8989.3,1,"SPL")),%=0 90 U %ZFN F R %X#255:5 Q:$ZEOF S %2=%X D CL2 Q:%Z1<% 91 SPLEX C %ZFN:(DELETE) K:%ZFN]"" IO(1,%ZFN) D CLOSE^ZISPL1 K %Y,%X,%1,%ZFN Q 92 ; 93 CL2 S %=%+1 I %Z1<% S ^XMBS(3.519,XS,2,%,0)="*** INCOMPLETE REPORT -- SPOOL DOCUMENT LINE LIMIT EXCEEDED ***",$P(^XMB(3.51,%ZDA,0),"^",11)=1 Q 94 I %2[$C(12) S ^XMBS(3.519,XS,2,%,0)="|TOP|" Q 95 S ^XMBS(3.519,XS,2,%,0)=%2 Q 96 ; 97 HFS G HFS^%ZISF 98 REWMT(IO,IOPAR) ;Rewind Magtape 99 S X="REWERR^%ZIS4",@^%ZOSF("TRAP") 100 U IO W *5 101 Q 1 102 REWSDP(IO,IOPAR) ;Rewind SDP 103 G REW1 104 REWHFS(IO,IOPAR) ;Rewind Host File. 105 REW1 S X="REWERR^%ZIS4",@^%ZOSF("TRAP") 106 U IO:(REWIND) 107 Q 1 108 REWERR ;Error encountered 109 Q 0 1 %ZIS4 ;ISF/RWF,DW - DEVICE HANDLER SPECIFIC CODE (GT.M for Unix/VMS) ;03/07/2007 2 ;;8.0;KERNEL;**275,425**;Jul 10, 1995;Build 18 3 ; 4 OPEN ;From %ZIS3 for TRM 5 G OPN2:$D(IO(1,IO)) 6 S POP=0 D OP1 G NOPEN:'$D(IO(1,IO)) 7 OPN2 ; 8 I $D(%ZISHP),'$D(IOP) W !,*7," Routing to device "_$P(^%ZIS(1,%E,0),"^",1)_$S($D(^(1)):" "_$P(^(1),"^",1)_" ",1:"") 9 Q 10 NOPEN I %IS'["D",$D(%ZISHP)!(%ZISHG]"") S POP=1 Q 11 I '$D(IOP) W *7," [BUSY]" W " ... RETRY" S %=2,U="^" D YN^%ZIS1 G OPEN:%=1 12 S POP=1 Q 13 Q 14 ;Why no open paraneters??? 15 OP1 N $ES,$ET S $ET="G OPNERR^%ZIS4" 16 L:$D(%ZISLOCK) +@%ZISLOCK:60 17 O IO::%ZISTO S:$T IO(1,IO)="" S:'$T POP=1 L:$D(%ZISLOCK) -@%ZISLOCK 18 Q 19 OPNERR ;Open Error 20 S POP=1,IO("LASTERR")=$G(IO("ERROR")),IO("ERROR")=$$EC^%ZOSV,$EC="" Q 21 ; 22 O ;From %ZIS6 for other types. 23 D:%IS["L" ZIO 24 LCKGBL ;Lock Global 25 I %ZTYPE="CHAN" N % S %=$G(^%ZIS(1,+%E,"GBL")) I $L(%) L @("+^"_%_":0") S:'$T POP=1 I POP W:'$D(IOP) !,?5,*7,"[DEVICE IS BUSY]" Q 26 I $D(IO("S")),$D(^%ZIS(2,IO("S"),10)),^(10)]"" U IO(0) D X10^ZISX 27 OPAR I $D(IOP),%ZTYPE="HFS",$D(%IS("HFSIO")),$D(%IS("IOPAR")),%IS("HFSIO")]"" S IO=%IS("HFSIO"),%ZISOPAR=%IS("IOPAR") 28 I %ZTYPE="CHAN" D TCPIP Q:POP G OXECUTE^%ZIS6 29 S %A=%ZISOPAR_$S(%ZISOPAR["):":"",%ZTYPE["CHAN"&($P(%ZTIME,"^",3)="n"):"",1:":"_%ZISTO) 30 N % S %(IO)="",%=$P($P($NA(%(IO)),"(",2),")") 31 S %A=%_$E(":",%A]"")_%A 32 D O1 I POP D Q 33 .I %ZTYPE="HFS",'$D(IOP),$G(IO("ERROR"))["file not found" W !,?5,*7,"[File Not Found]" Q 34 .W:'$D(IOP) !,?5,*7,"[DEVICE IS BUSY]" Q 35 ;S IO(1,IO)="" U IO S:'(IO=IO(0)&'$D(IO("S"))&'$D(ZTQUEUED)) $X=0,$Y=0 I %ZTYPE["TRM" U IO:(WIDTH=+%Z91) 36 U IO S $X=0,$Y=0 I %ZTYPE["TRM" U IO:(WIDTH=+%Z91) 37 I %ZISUPAR]"" S %A1=""""_IO_""":"_%ZISUPAR U @%A1 38 ;U:%IS'[0 IO(0) 39 G OXECUTE^%ZIS6 40 ; 41 O1 N $ES,$ET S $ET="G OPNERR^%ZIS4" 42 L:$D(%ZISLOCK) +@%ZISLOCK:60 43 O @%A S:'$T&(%A?.E1":".N) POP=1 S:'POP IO(1,IO)="" L:$D(%ZISLOCK) -@%ZISLOCK 44 S IO("ERROR")="" Q 45 ; 46 ;Need to find out how to get IP address 47 ZIO N %,%1 S (%,%1)=$ZIO 48 I $ZV["VMS",%["_TNA" D 49 . S (%,%1)=$ZGETDVI($I,"TT_ACCPORNAM") 50 . S %=$S(%["Host:":$P($P(%,"Host: ",2)," ")_":"_$P(%,"Port: ",2),1:%) S:%[" " %=$TR(%," ") 51 I $ZV'["VMS" D 52 . S (%,%1)=$ZTRNLNM("REMOTEHOST") S:$L(%) %1="Host:"_% S:'$L(%) %=$ZIO 53 S IO("ZIO")=% S:(%1["Host:")&'$D(IO("IP")) IO("IP")=$P(%,":") 54 Q 55 ; 56 TCPIP ;For TCP/IP devices 57 N %S 58 S %ZISTO=$G(%ZISTO,3) 59 S %A="IO:"_$S($E(%ZISOPAR)="(":"",1:"(")_%ZISOPAR_$S($E(%ZISOPAR,$L(%ZISOPAR))=")":"",1:")")_":%ZISTO:""SOCKET""" 60 ;U $P W !,"%A=",%A 61 O @%A I '$T S POP=1 Q ;D O1 ;Do the open. 62 U IO:(WIDTH=512:NOWRAP:EXCEPT="G OPNERR^%ZIS4") S %S=$KEY 63 U $P ;W !,"$KEY=",%S 64 Q 65 ; 66 SPOOL ;%ZDA=pointer to ^XMB(3.51, %ZFN=spool file name. 67 I $D(ZISDA) W:'$D(IOP) !?5,*7,"You may not Spool the printing of a Spool document" G N 68 I $D(DUZ)[0 W:'$D(IOP) !,"Must be a valid user." G N 69 R S %ZY=-1 D NEWDOC^ZISPL1 G N:%ZY'>0 S %ZDA=+%ZY,%ZFN=$P(%ZY(0),U,2),IO("DOC")=$P(%ZY(0),U,1) G OK:$D(IO("Q")) 70 G:'%ZISB OK I '$P(%ZY,"^",3),%ZFN]"" D SPL3 G N:%ZFN']"",DOC 71 S %ZFN=IO_"SPOOL_no_"_%ZDA_".TMP" D SPL2 G:%ZFN']"" N S $P(^XMB(3.51,%ZDA,0),U,2)=%ZFN,^XMB(3.51,"C",%ZFN,%ZDA)="" 72 DOC S IO=%ZFN,IO("SPOOL")=%ZDA,^XUTL("XQ",$J,"SPOOL")=%ZDA,IOF="#" 73 I $D(^%ZIS(1,%ZISIOS,1)),$P(^(1),"^",8),$O(^("SPL",0)) S ^XUTL("XQ",$J,"ADSPL")=%ZISIOS,ZISPLAD=%ZISIOS 74 OK K %ZDA,%ZFN Q 75 N K %ZDA,%ZFN,IO("DOC") S POP=1 Q 76 SPL2 O %ZFN:(NEWVERSION:WORLD=RWD) G:$ZA<0 SPL4 S IO(1,%ZFN)="" Q 77 SPL3 N X S X="SPL4^%ZIS4",@^%ZOSF("TRAP") 78 O %ZFN:READONLY:1 S:'$T ZISPLQ=1 G:$ZA<0!('$T) SPL4 S IO(1,%ZFN)="" Q 79 SPL4 W:'$D(IOP)&'$D(ZTQUEUED) !?5,*7,"Couldn't open the spool file." S %ZFN="" Q 80 CLOSE N %Z1 C:IO]"" IO K:IO]"" IO(1,IO) D FILE^ZISPL1 I %ZDA'>0 K ZISPLAD Q 81 S %ZFN=$P(%ZS,"^",2) D SPL3 Q:%ZFN']"" U %ZFN S %ZCR=$C(13),%Y="",X="SPLEOF^%ZIS4",@^%ZOSF("TRAP") 82 S %Z1=+$G(^XTV(8989.3,1,"SPL")) 83 F %=0:0 R %X#255:5 Q:$ZA<0 S %2=%X D CL2 G:%Z1<% SPLEX 84 SPLEOF I $ZE'["ENDO" Q ;Send error up 85 SPLEX C %ZFN:(DELETE) K:%ZFN]"" IO(1,%ZFN) D CLOSE^ZISPL1 K %Y,%X,%1,%ZFN Q 86 ; 87 CL2 S %=%+1 I %Z1<% S ^XMBS(3.519,XS,2,%,0)="*** INCOMPLETE REPORT -- SPOOL DOCUMENT LINE LIMIT EXCEEDED ***",$P(^XMB(3.51,%ZDA,0),"^",11)=1 Q 88 I %2[$C(12) S ^XMBS(3.519,XS,2,%,0)="|TOP|" Q 89 S ^XMBS(3.519,XS,2,%,0)=%2 Q 90 ; 91 HFS G HFS^%ZISF 92 REWMT(IO,IOPAR) ;Rewind Magtape 93 S X="REWERR^%ZIS4",@^%ZOSF("TRAP") 94 U IO W *5 95 Q 1 96 REWSDP(IO,IOPAR) ;Rewind SDP 97 G REW1 98 REWHFS(IO,IOPAR) ;Rewind Host File. 99 REW1 S X="REWERR^%ZIS4",@^%ZOSF("TRAP") 100 U IO:(REWIND) 101 Q 1 102 REWERR ;Error encountered 103 Q 0 -
WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZIS4ONT.m
r613 r623 1 %ZIS4 ;SFISC/RWF,AC - DEVICE HANDLER SPOOL SPECIFIC CODE (Cache) ;1/24/08 16:08 2 ;;8.0;KERNEL;**34,59,69,191,278,293,440**;Jul 10, 1995;Build 13 3 ;Per VHA Directive 2004-038, this routine should not be modified 4 OPEN ;Called for TRM devices 5 G OPN2:$D(IO(1,IO)) 6 S POP=0 D OP1 G NOPEN:'$D(IO(1,IO)) 7 OPN2 ; 8 I $D(%ZISHP),'$D(IOP) W !,$C(7)_" Routing to device "_$P(^%ZIS(1,%E,0),"^",1)_$S($D(^(1)):" "_$P(^(1),"^",1)_" ",1:"") 9 Q 10 NOPEN ; 11 I %IS'["D",$D(%ZISHP)!(%ZISHG]"") S POP=1 Q 12 I '$D(IOP) W $C(7)_" [BUSY]" W " ... RETRY" S %=2,U="^" D YN^%ZIS1 G OPEN:%=1 13 S POP=1 Q 14 Q 15 OP1 N $ET S $ET="G OPNERR^%ZIS4" 16 I $D(%ZISLOCK) L +@%ZISLOCK:5 E S POP=1 Q 17 O IO::%ZISTO S:$T IO(1,IO)="" S:'$T POP=1 18 Q 19 OPNERR S POP=1,IO("LASTERR")=$G(IO("ERROR")),IO("ERROR")=$ZE,$EC="" 20 Q 21 ; 22 O ;Gets called for all devices 23 N X,%A1 24 D:%ZIS["L" ZIO 25 I $D(IO("S")),$D(^%ZIS(2,IO("S"),10)),^(10)]"" U IO(0) D X10^ZISX ;Open Printer port 26 OPAR I $D(IOP),%ZTYPE="HFS",$D(%ZIS("HFSIO")),$D(%ZIS("IOPAR")),%ZIS("HFSIO")]"" S IO=%ZIS("HFSIO"),%ZISOPAR=%ZIS("IOPAR") 27 S %A=$S($L(%ZISOPAR):%ZISOPAR,%ZTYPE'["TRM":"",$E(%ZISIOST,1)="C":"("_+%Z91_":""C"")",$E(%ZISIOST,1,2)="PK":"("_+%Z91_":""P"")",1:+%Z91) 28 S %A=%A_$S(%A["):":"",%ZTYPE["OTH"&($P(%ZTIME,"^",3)="n"):"",1:":"_%ZISTO),%A=""""_IO_""""_$E(":",%A]"")_%A 29 D O1 I POP W:'$D(IOP) !,?5,$C(7)_"[Device is BUSY]" Q 30 ;I %ZTYPE="HFS" U IO S X=IO,IO=IO_";"_$P($ZIO,";",2),IO(1,IO)="" K IO(1,X) 31 U IO S $X=0,$Y=0 32 I $L(%ZISUPAR) S %A1=""""_IO_""":"_%ZISUPAR U @%A1 33 ;U:%IS'[0 IO(0) 34 G OXECUTE^%ZIS6 35 ; 36 O1 N $ET S $ET="G OPNERR^%ZIS4" 37 I $D(%ZISLOCK) L +@%ZISLOCK:5 E S POP=1 Q 38 O @%A S:'$T&(%A?.E1":".N) POP=1 S:'POP IO(1,IO)="" 39 S IO("ERROR")="" 40 Q 41 ;Version 3 used ip/port, Version 4 has ip:port|xx 42 ZIO N %,%1 S %=$ZIO,%1=$$VERSION^%ZOSV 43 S IO("ZIO")=$S(%1<4:$I,1:$ZIO),%1=$S(%["/":"/",1:":") 44 ;Drop prefix 45 S:%["|TNT|" %=$E(%,6,999) S:%["|TNA|" %=$E(%,6,999) 46 ;Get IP name or number 47 I '$D(IO("IP")) D 48 . S:$P(%,%1)["." IO("IP")=$P(%,%1) 49 Q 50 ; 51 SPOOL ;%ZDA=pointer to ^XMB(3.51, %ZFN=spool file Num/Name. 52 N %ZOS S %ZOS=$$OS^%ZOSV 53 I '$D(^XMB(3.51,0)) W:'$D(IOP) !?5,"The spooler files are not setup in this account." G NO 54 I $D(ZISDA) W:'$D(IOP) !?5,$C(7)_"You may not Spool the printing of a Spool document" G NO 55 I $D(DUZ)[0 W:'$D(IOP) !,"Must be a valid user." G NO 56 ;Get entry in Spool Doc file 57 R S %ZY=-1 D NEWDOC^ZISPL1:$D(DUZ)=11 G NO:%ZY'>0 S %ZDA=+%ZY,%ZFN=$P(%ZY(0),U,2),IO("DOC")=$P(%ZY(0),U,1) G OK:$D(IO("Q")) 58 G:'%ZISB OK I '$P(%ZY,"^",3),%ZFN]"" D SPL3 G NO:%ZFN<0,DOC 59 I %ZOS="NT" D G:%ZFN>255 NO 60 . F %ZFN=1:1:260 I '$D(^XMB(3.51,"C",%ZFN))!$D(^(%ZFN,%ZDA)) Q:%ZFN<256 W:'$D(IOP) $C(7)_" DELETE SOME OTHER DOCUMENT!" Q 61 . Q:%ZFN>255 D SPL2 S $P(^XMB(3.51,%ZDA,0),U,2)=%ZFN,^XMB(3.51,"C",%ZFN,%ZDA)="" 62 I %ZOS="VMS" D G:%ZFN=-1 NO 63 . S %ZFN=IO_"SPOOL_no_"_%ZDA_".TMP" D SPL2 Q:%ZFN=-1 S $P(^XMB(3.51,%ZDA,0),U,2)=%ZFN,^XMB(3.51,"C",%ZFN,%ZDA)="",IO=%ZFN 64 DOC S IO("SPOOL")=%ZDA,^XUTL("XQ",$J,"SPOOL")=%ZDA 65 I $D(^%ZIS(1,%ZISIOS,1)),$P(^(1),"^",8),$O(^("SPL",0)) S ^XUTL("XQ",$J,"ADSPL")=%ZISIOS,ZISPLAD=%ZISIOS 66 OK K %ZDA,%ZFN Q 67 NO K %ZDA,%ZFN,IO("DOC") S POP=1 Q 68 ; 69 SPL2 I %ZOS="NT" O IO:(%ZFN:0) S IO(1,IO)="",^SPOOL(0,IO("DOC"),%ZFN)="",^SPOOL(%ZFN,0)=IO("DOC")_"{"_$H Q 70 ;VMS 71 O %ZFN:("WNS"):2 G:'$T SPL4 S IO(1,%ZFN)="" Q 72 ; 73 SPL3 I %ZOS="NT" G SPL4:'$D(^SPOOL(%ZFN,2147483647)) O IO:(%ZFN:$P(^(2147483647),"{",3)):1 S:'$T ZISPLQ=1 K ^(2147483647) S IO(1,IO)="" Q 74 ;VMS 75 N $ETRAP S $ETRAP="S $EC="""" G SPL4^%ZIS4" 76 O %ZFN:"RV":1 S:'$T ZISPLQ=1 G:$ZA<0!('$T) SPL4 S IO(1,%ZFN)="" Q 77 ; 78 SPL4 W:'$D(IOP) !,"Spool file already open" S %ZFN=-1 Q 79 ; 80 CLOSE N %ZOS,%Z1,%ZCR,%2,%3,%X,%Y,ZTSK,%ZFN S %ZOS=$$OS^%ZOSV 81 I %ZOS="NT",IO=2,$D(IO(1,IO)) K IO(1,IO) C IO 82 I %ZOS="VMS",IO]"",$D(IO(1,IO)) U IO S %ZFN=$ZIO C IO K IO(1,IO) 83 ;See that ZTSK is set so we will move to the global now. 84 S ZTSK=$G(ZTSK,1) D FILE^ZISPL1 I %ZDA'>0 K ZISPLAD Q 85 G:%ZOS="VMS" CLVMS 86 S %ZFN=$P(%ZS,"^",2),%ZCR=$C(13),%Y="",%=0,%3=$P(^SPOOL(%ZFN,2147483647),"{",3) 87 S %Z1=+$G(^XTV(8989.3,1,"SPL")) 88 F %2=1:1:%3 Q:'$D(^SPOOL(%ZFN,%2)) S %X=^SPOOL(%ZFN,%2) D 89 . I %Z1<% D LIMIT S %2=%3 Q 90 . I %X[$C(13,12) D:$L($P(%X,$C(13))) ADD($P(%X,$C(13))) D ADD("|TOP|") Q 91 . D ADD($P(%X,$C(13),1)) 92 K ^SPOOL(%ZFN),^SPOOL(0,$P(%ZS,U,1)),%Y,%X,%1,%2,%3 D CLOSE^ZISPL1 93 Q 94 ADD(L) S %=%+1,^XMBS(3.519,XS,2,%,0)=L Q 95 LIMIT D ADD("*** INCOMPLETE REPORT -- SPOOL DOCUMENT LINE LIMIT EXCEEDED ***") S $P(^XMB(3.51,%ZDA,0),"^",11)=1 96 Q 97 CLVMS ;Close for Cache VMS 98 N $ES,$ET S $ET="D:$EC'[""ENDOF"" ^%ZTER,UNWIND^%ZTER S $EC="""" D SPLEX^%ZIS4,UNWIND^%ZTER" 99 S %ZA=$ZU(68,40,1) ;Work like DSM 100 ;%ZFN Could be set at the top 101 S %ZFN=$S($G(%ZFN)]"":%ZFN,1:$P(%ZS,"^",2)) D SPL3 Q:%ZFN']"" U %ZFN S %ZCR=$C(13),%Y="" 102 S %Z1=+$G(^XTV(8989.3,1,"SPL")),%=0 103 F R %X#255:5 Q:$ZEOF<0 D G:%Z1<% SPLEX 104 . I %Z1<% D LIMIT Q 105 . I %X[$C(12) D Q 106 . . S %Y=$P(%X,$C(12)) D:$L(%Y) ADD(%Y),ADD("|TOP|") 107 . . S %Y=$P(%X,$C(12),2) D:$L(%Y) ADD(%Y) 108 . . Q 109 . D ADD(%X) 110 . Q 111 SPLEX C %ZFN:"D" K:%ZFN]"" IO(1,%ZFN) D CLOSE^ZISPL1 K %Y,%X,%1,%ZFN Q 112 ; 113 ; 114 HFS G HFS^%ZISF 115 REWMT(IO2,IOPAR) ;Rewind Magtape 116 N $ETRAP S $ET="G REWERR^%ZIS4" 117 U IO2 W *5 118 Q 1 119 REWSDP(IO2,IOPAR) ;Rewind SDP 120 G REW1 121 REWHFS(IO2,IOPAR) ;Rewind Host File. 122 REW1 ;ZIS set % to the current $I so need to update % if = IO 123 N NIO,OP,$ETRAP 124 S $ET="G REWERR^%ZIS4" 125 C IO2 ;You do a rewind to read the file. 126 S OP=$S($ZV["VMS":"RV",1:"RS") 127 O IO2:(OP):1 S IO(1,IO2)="" 128 Q 1 129 REWERR ;Error encountered 130 S IO("ERROR")=$EC,$ECODE="" 131 Q 0 1 %ZIS4 ;SFISC/RWF,AC - DEVICE HANDLER SPOOL SPECIFIC CODE (OpenM/WNT) ;11/03/2003 17:32 2 ;;8.0;KERNEL;**34,59,69,191,278,293**;Jul 10, 1995 3 ; 4 OPEN G OPN2:$D(IO(1,IO)) 5 S POP=0 D OP1 G NOPEN:'$D(IO(1,IO)) 6 OPN2 I $D(%ZISHP),'$D(IOP) W !,$C(7)_" Routing to device "_$P(^%ZIS(1,%E,0),"^",1)_$S($D(^(1)):" "_$P(^(1),"^",1)_" ",1:"") 7 Q 8 NOPEN I %IS'["D",$D(%ZISHP)!(%ZISHG]"") S POP=1 Q 9 I '$D(IOP) W $C(7)_" [BUSY]" W " ... RETRY" S %=2,U="^" D YN^%ZIS1 G OPEN:%=1 10 K:%E'=%H ^XUTL("ZISPARAM",IO) 11 S POP=1 Q 12 Q 13 OP1 N X S X="OPNERR^%ZIS4",@^%ZOSF("TRAP") 14 L:$D(%ZISLOCK) +@%ZISLOCK:60 15 O IO::%ZISTO S:$T IO(1,IO)="" S:'$T POP=1 L:$D(%ZISLOCK) -@%ZISLOCK 16 Q 17 OPNERR S POP=1,IO("LASTERR")=$G(IO("ERROR")),IO("ERROR")=$ZE,$EC="" Q 18 ; 19 O N X D:%IS["L" ZIO 20 I $D(IO("S")),$D(^%ZIS(2,IO("S"),10)),^(10)]"" U IO(0) D X10^ZISX ;Open Printer port 21 OPAR I $D(IOP),%ZTYPE="HFS",$D(%IS("HFSIO")),$D(%IS("IOPAR")),%IS("HFSIO")]"" S IO=%IS("HFSIO"),%ZISOPAR=%IS("IOPAR") 22 S %A=$S(%ZISOPAR]"":%ZISOPAR,%ZTYPE'["TRM":"",%ZISIOST?1"C".E:"("_+%Z91_":""C"")",%ZISIOST?1"PK".E:"("_+%Z91_":""P"")",1:+%Z91) 23 S %A=%A_$S(%A["):":"",%ZTYPE["OTH"&($P(%ZTIME,"^",3)="n"):"",1:":"_%ZISTO),%A=""""_IO_""""_$E(":",%A]"")_%A 24 D O1 I POP W:'$D(IOP) !,?5,$C(7)_"[Device is BUSY]" Q 25 ;I %ZTYPE="HFS" U IO S X=IO,IO=IO_";"_$P($ZIO,";",2),IO(1,IO)="" K IO(1,X) 26 U IO S $X=0,$Y=0 27 I %ZISUPAR]"" S %A1=""""_IO_""":"_%ZISUPAR U @%A1 28 ;U:%IS'[0 IO(0) 29 G OXECUTE^%ZIS6 30 ; 31 O1 N X S X="OPNERR^%ZIS4",@^%ZOSF("TRAP") 32 L:$D(%ZISLOCK) +@%ZISLOCK:60 33 O @%A S:'$T&(%A?.E1":".N) POP=1 S:'POP IO(1,IO)="" 34 L:$D(%ZISLOCK) -@%ZISLOCK 35 S IO("ERROR")="" 36 Q 37 ;Version 3 used ip/port, Version 4 has ip:port|xx 38 ZIO N %,%1 S %=$ZIO,%1=$$VERSION^%ZOSV 39 S IO("ZIO")=$S(%1<4:$I,1:$ZIO),%1=$S(%["/":"/",1:":") 40 ;Drop prefix 41 S:%["|TNT|" %=$E(%,6,999) S:%["|TNA|" %=$E(%,6,999) 42 ;Get IP name or number 43 I '$D(IO("IP")) D 44 . S:$P(%,%1)["." IO("IP")=$P(%,%1) 45 Q 46 ; 47 SPOOL ;%ZDA=pointer to ^XMB(3.51, %ZFN=spool file Num/Name. 48 N %ZOS S %ZOS=$$OS^%ZOSV 49 I '$D(^XMB(3.51,0)) W:'$D(IOP) !?5,"The spooler files are not setup in this account." G NO 50 I $D(ZISDA) W:'$D(IOP) !?5,$C(7)_"You may not Spool the printing of a Spool document" G NO 51 I $D(DUZ)[0 W:'$D(IOP) !,"Must be a valid user." G NO 52 ;Get entry in Spool Doc file 53 R S %ZY=-1 D NEWDOC^ZISPL1:$D(DUZ)=11 G NO:%ZY'>0 S %ZDA=+%ZY,%ZFN=$P(%ZY(0),U,2),IO("DOC")=$P(%ZY(0),U,1) G OK:$D(IO("Q")) 54 G:'%ZISB OK I '$P(%ZY,"^",3),%ZFN]"" D SPL3 G NO:%ZFN<0,DOC 55 I %ZOS="NT" D G:%ZFN>255 NO 56 . F %ZFN=1:1:260 I '$D(^XMB(3.51,"C",%ZFN))!$D(^(%ZFN,%ZDA)) Q:%ZFN<256 W:'$D(IOP) $C(7)_" DELETE SOME OTHER DOCUMENT!" Q 57 . Q:%ZFN>255 D SPL2 S $P(^XMB(3.51,%ZDA,0),U,2)=%ZFN,^XMB(3.51,"C",%ZFN,%ZDA)="" 58 I %ZOS="VMS" D G:%ZFN=-1 NO 59 . S %ZFN=IO_"SPOOL_no_"_%ZDA_".TMP" D SPL2 Q:%ZFN=-1 S $P(^XMB(3.51,%ZDA,0),U,2)=%ZFN,^XMB(3.51,"C",%ZFN,%ZDA)="",IO=%ZFN 60 DOC S IO("SPOOL")=%ZDA,^XUTL("XQ",$J,"SPOOL")=%ZDA 61 I $D(^%ZIS(1,%ZISIOS,1)),$P(^(1),"^",8),$O(^("SPL",0)) S ^XUTL("XQ",$J,"ADSPL")=%ZISIOS,ZISPLAD=%ZISIOS 62 OK K %ZDA,%ZFN Q 63 NO K %ZDA,%ZFN,IO("DOC") S POP=1 Q 64 ; 65 SPL2 I %ZOS="NT" O IO:(%ZFN:0) S IO(1,IO)="",^SPOOL(0,IO("DOC"),%ZFN)="",^SPOOL(%ZFN,0)=IO("DOC")_"{"_$H Q 66 ;VMS 67 O %ZFN:("WNS"):2 G:'$T SPL4 S IO(1,%ZFN)="" Q 68 ; 69 SPL3 I %ZOS="NT" G SPL4:'$D(^SPOOL(%ZFN,2147483647)) O IO:(%ZFN:$P(^(2147483647),"{",3)):1 S:'$T ZISPLQ=1 K ^(2147483647) S IO(1,IO)="" Q 70 ;VMS 71 N $ETRAP S $ETRAP="S $EC="""" G SPL4^%ZIS4" 72 O %ZFN:"RV":1 S:'$T ZISPLQ=1 G:$ZA<0!('$T) SPL4 S IO(1,%ZFN)="" Q 73 ; 74 SPL4 W:'$D(IOP) !,"Spool file already open" S %ZFN=-1 Q 75 ; 76 CLOSE N %ZOS,%Z1,%ZCR,%2,%3,%X,%Y,ZTSK,%ZFN S %ZOS=$$OS^%ZOSV 77 I %ZOS="NT",IO=2,$D(IO(1,IO)) K IO(1,IO) C IO 78 I %ZOS="VMS",IO]"",$D(IO(1,IO)) U IO S %ZFN=$ZIO C IO K IO(1,IO) 79 ;See that ZTSK is set so we will move to the global now. 80 S ZTSK=$G(ZTSK,1) D FILE^ZISPL1 I %ZDA'>0 K ZISPLAD Q 81 G:%ZOS="VMS" CLVMS 82 S %ZFN=$P(%ZS,"^",2),%ZCR=$C(13),%Y="",%=0,%3=$P(^SPOOL(%ZFN,2147483647),"{",3) 83 S %Z1=+$G(^XTV(8989.3,1,"SPL")) 84 F %2=1:1:%3 Q:'$D(^SPOOL(%ZFN,%2)) S %X=^SPOOL(%ZFN,%2) D 85 . I %Z1<% D LIMIT S %2=%3 Q 86 . I %X[$C(13,12) D:$L($P(%X,$C(13))) ADD($P(%X,$C(13))) D ADD("|TOP|") Q 87 . D ADD($P(%X,$C(13),1)) 88 K ^SPOOL(%ZFN),^SPOOL(0,$P(%ZS,U,1)),%Y,%X,%1,%2,%3 D CLOSE^ZISPL1 89 Q 90 ADD(L) S %=%+1,^XMBS(3.519,XS,2,%,0)=L Q 91 LIMIT D ADD("*** INCOMPLETE REPORT -- SPOOL DOCUMENT LINE LIMIT EXCEEDED ***") S $P(^XMB(3.51,%ZDA,0),"^",11)=1 92 Q 93 CLVMS ;Close for Cache VMS 94 N $ES,$ET S $ET="D:$EC'[""ENDOF"" ^%ZTER,UNWIND^%ZTER S $EC="""" D SPLEX^%ZIS4,UNWIND^%ZTER" 95 S %ZA=$ZU(68,40,1) ;Work like DSM 96 ;%ZFN Could be set at the top 97 S %ZFN=$S($G(%ZFN)]"":%ZFN,1:$P(%ZS,"^",2)) D SPL3 Q:%ZFN']"" U %ZFN S %ZCR=$C(13),%Y="" 98 S %Z1=+$G(^XTV(8989.3,1,"SPL")),%=0 99 F R %X#255:5 Q:$ZEOF<0 D G:%Z1<% SPLEX 100 . I %Z1<% D LIMIT Q 101 . I %X[$C(12) D Q 102 . . S %Y=$P(%X,$C(12)) D:$L(%Y) ADD(%Y),ADD("|TOP|") 103 . . S %Y=$P(%X,$C(12),2) D:$L(%Y) ADD(%Y) 104 . . Q 105 . D ADD(%X) 106 . Q 107 SPLEX C %ZFN:"D" K:%ZFN]"" IO(1,%ZFN) D CLOSE^ZISPL1 K %Y,%X,%1,%ZFN Q 108 ; 109 ; 110 HFS G HFS^%ZISF 111 REWMT(IO2,IOPAR) ;Rewind Magtape 112 N $ETRAP S $ET="G REWERR^%ZIS4" 113 U IO2 W *5 114 Q 1 115 REWSDP(IO2,IOPAR) ;Rewind SDP 116 G REW1 117 REWHFS(IO2,IOPAR) ;Rewind Host File. 118 REW1 ;ZIS set % to the current $I so need to update % if = IO 119 N NIO,OP,$ETRAP 120 S $ET="G REWERR^%ZIS4" 121 C IO2 ;You do a rewind to read the file. 122 S OP=$S($ZV["VMS":"RV",1:"RS") 123 O IO2:(OP):1 S IO(1,IO2)="" 124 Q 1 125 REWERR ;Error encountered 126 S IO("ERROR")=$EC,$ECODE="" 127 Q 0 -
WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZIS6.m
r613 r623 1 %ZIS6 ;SFISC/AC - DEVICE HANDLER -- RESOURCES ;1/24/08 16:09 2 ;;8.0;KERNEL;**24,49,69,118,127,136,440**;JUL 10, 1995;Build 13 3 ;Per VHA Directive 2004-038, this routine should not be modified 4 ;Expect that IO is current device 5 OXECUTE ;Open Execute 6 I $D(^%ZIS(2,%ZISIOST(0),2))=1 S %Y=^(2) D 2 7 ANSBAK ;Answer Back 8 I $D(^%ZIS(2,%ZISIOST(0),102)) S %Y=^(102) D 2 E S POP=1 D:'$D(IOP) SAY($C(7)_"[NOT ON LINE]") C:%ZISB IO K IO(1,IO) G QUIT 9 I $D(%ZISMTR) X ^%ZOSF("MAGTAPE") U IO W:$D(%MT("REW")) @%MT("REW") U IO(0) K %MT 10 G QUIT:'$D(IO("P")) 11 I $F(IO("P"),"B"),$D(^%ZIS(2,%ZISIOST(0),7)) S %Y=$P(^(7),"^",1) I %Y]"" W @%Y 12 S %Y=$F(IO("P"),"P") G QLTY:'%Y S %Y=+$E(IO("P"),%Y,99),%X=$S(%Y=16:12.1,%Y=10!(%Y=12):5,1:"") G QLTY:'%X 13 S %Y=$S($D(^%ZIS(2,%ZISIOST(0),%X)):$P(^(%X),"^",$S(%Y=12:2,1:1)),1:"") 14 I %Y]"" W @%Y 15 QLTY S %Y=$F(IO("P"),"Q") Q:'%Y S %Y=+$E(IO("P"),%Y,99),%X=$S(%Y<0!(%Y>2):0,1:%Y+1) 16 I %X S %Y=$S($D(^%ZIS(2,%ZISIOST(0),12.2)):$P(^(12.2),"^",%X),1:"") I %Y]"" W @%Y 17 QUIT U:%IS'[0 IO(0) 18 Q 19 2 Q:%Y="" I %IS'[0,$D(^%ZIS(1,+%H,"TYPE")),^("TYPE")["TRM" D OH Q:POP 20 S %X=$T U IO D %Y^ZISX ;Q:'%X U IO(0) 21 Q 22 OH Q:$S($G(IO(0))]"":$D(IO(1,IO(0))),1:0) 23 N X S X="OPNERR^%ZIS4",@^%ZOSF("TRAP") 24 O IO(0)::0 S IO(1,IO(0))="" Q ;See that HOME DEVICE is open. 25 ; 26 SAY(%SAY) ; 27 Q:%IS[0 U IO(0) W %SAY U IO 28 Q 29 RES1 ;Allocate a resource slot, Release in %ZISC. 30 N A,L,X,%ZISD0 31 S %ZISD0=$O(^%ZISL(3.54,"B",IO,0)) 32 I '%ZISD0 S %ZISD0=$$RADD(IO) ;New one 33 L +^%ZISL(3.54,%ZISD0,0):2 I '$T S POP=1 W:'$D(IOP) *7," [NOT Available]" G RESX 34 RES2 S X=$P(^%ZISL(3.54,%ZISD0,0),"^",2) 35 I X<1 S POP=1 W:'$D(IOP) *7," [NOT Available]" G RESX 36 S X=$S(X>0:X-1,1:0),$P(^%ZISL(3.54,%ZISD0,0),"^",2)=X 37 ; 38 R1 ;Grab a slot 39 S IO(1,IO)="RES",A=$G(^%ZISL(3.54,%ZISD0,1,0),"^3.542^^") 40 F L=1:1:%ZISRL I '$D(^%ZISL(3.54,%ZISD0,1,L,0)) Q 41 I '$T K IO(1,IO) G RES2 ;No free slots 42 S ^%ZISL(3.54,%ZISD0,1,L,0)=L_"^"_%ZISV_"^"_$J_"^"_$G(ZTSK)_"^"_$H,^%ZISL(3.54,"AJ",$J,%ZISD0,L)="",^%ZISL(3.54,%ZISD0,1,"B",L,L)="" 43 S $P(A,"^",3,4)=L_U_($P(A,U,4)+1),^%ZISL(3.54,%ZISD0,1,0)=A 44 RESX L -^%ZISL(3.54,%ZISD0,0) Q 45 ; 46 RADD(X) ;Add Resource 47 N %1,%2 48 S %1=$G(^%ZISL(3.54,0),"RESOURCE^3.54^^"),%2=$P(%1,U,3) 49 F %2=%2:1 Q:'$D(^%ZISL(3.54,%2,0)) 50 S $P(^%ZISL(3.54,0),U,3,4)=%2_U_($P(%1,U,4)+1),^%ZISL(3.54,%2,0)=X_"^"_$G(%ZISRL,1),^%ZISL(3.54,"B",X,%2)="" 51 Q %2 52 ; 53 RESOK ;DEVOK check for RES devices, for all OS's. 54 N %ZISD0,%ZISD1 55 S Y=0,%ZISD0=$O(^%ZISL(3.54,"B",X,0)) 56 I '%ZISD0 S Y=-1,%ZISD0=$O(^%ZIS(1,"C",X,0)) Q:'%ZISD0 Q:'$D(^%ZIS(1,+%ZISD0,0)) Q:$P(^(0),"^")'=X Q:'$D(^("TYPE")) Q:^("TYPE")'="RES" S Y=0 Q 57 S X1=$G(^%ZISL(3.54,+%ZISD0,0)) 58 I $P(X1,"^",2)&(X=$P(X1,"^")) S Y=0 Q 59 S Y=999 F %ZISD1=0:0 S %ZISD1=$O(^%ZISL(3.54,%ZISD0,1,%ZISD1)) Q:%ZISD1'>0 I $D(^(%ZISD1,0)) S Y=$P(^(0),"^",3) Q 60 Q 61 ; 62 Q G Q^%ZIS3 63 HG ; 64 Q 65 SPL ;Spool type 66 N %E,%Z D MARGN^%ZIS3 W:'$D(IOP) ! D SPOOL^%ZIS4:%IS'["T" 67 G Q 68 MT D MARGN^%ZIS3,ASKPAR,AMTREW:'POP&'$D(IOP)&%ZISB W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T")) ;Magtape type 69 G Q 70 SDP ;Sequential disk processor type 71 D MARGN^%ZIS3,ASKPAR W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T")) 72 G Q 73 HFS ;Host File Server type 74 D MARGN^%ZIS3,HFS^%ZIS4 W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T")) 75 G Q 76 RES ;Resources 77 G Q:%IS["T" N X,X1 I %IS'["R"!'$D(IOP) S POP=1 W:'$D(IOP) *7," [NOT AVAILABLE]" Q 78 G Q:$D(IO(1,IO)) I %IS["T" S X=IO,X1="RES" D DEVOK^%ZIS3 S:Y POP=1 G Q:POP 79 D:%ZISB RES1 G Q 80 CHAN ;Network Channel type devices -- DecNet or TCP/IP devices. 81 I IO="SYS$NET",$I="SYS$INPUT:;" S IO(0)=IO U IO ;DECNET Server Device 82 D MARGN^%ZIS3:'POP,ASKPAR:'POP W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T")) 83 G Q 84 IMPC ;Imaging Work Station 85 BAR ;Bar Code 86 OTH ;Other Device type 87 D MARGN^%ZIS3:'POP,ASKPAR:'POP W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T")) 88 G Q 89 ; 90 ASKPAR ;Ask Parameters 91 G SETPAR^%ZIS3:$D(IOP),SETPAR^%ZIS3:'$P(^%ZIS(1,%E,0),"^",4) W " ADDRESS/PARAMETERS: " W:%ZISOPAR]"" %ZISOPAR_"// " D SBR^%ZIS1 D MSG1:%X="?" G ASKPAR:%X="?" S:%X]"" %ZISOPAR=%X I $D(DTOUT)!$D(DUOUT) S POP=1 92 I POP,%ZISB&(%ZTYPE["TRM") C IO K IO(1,IO) Q 93 Q:POP G SETPAR^%ZIS3 94 ; 95 AMTREW ;Mag Tape Rewind 96 I %ZISB,%ZTYPE="MT",'$D(IOP) W " REWIND" S %=2,U="^",%ZISDTIM=60 D YN^%ZIS1 K %ZISDTIM G AMTREW:%=0 I %=-1 S POP=1 Q 97 S:%=1 %ZISMTR=1 98 Q 99 MSG1 W !?5,"Enter the desired parameters needed to open the selected device.",!?25 100 Q 101 ; 1 %ZIS6 ;SFISC/AC - DEVICE HANDLER -- RESOURCES ;02/04/2000 08:14 2 ;;8.0;KERNEL;**24,49,69,118,127,136**;JUL 10, 1995 3 ;Expect that IO is current device 4 OXECUTE I $D(^%ZIS(2,%ZISIOST(0),2))=1 S %Y=^(2) D 2 5 ANSBAK I $D(^%ZIS(2,%ZISIOST(0),102)) S %Y=^(102) D 2 E S POP=1 D:'$D(IOP) SAY($C(7)_"[NOT ON LINE]") C:%ZISB IO K IO(1,IO) G QUIT 6 I $D(%ZISMTR) X ^%ZOSF("MAGTAPE") U IO W:$D(%MT("REW")) @%MT("REW") U IO(0) K %MT 7 G QUIT:'$D(IO("P")) 8 I $F(IO("P"),"B"),$D(^%ZIS(2,%ZISIOST(0),7)) S %Y=$P(^(7),"^",1) I %Y]"" W @%Y 9 S %Y=$F(IO("P"),"P") G QLTY:'%Y S %Y=+$E(IO("P"),%Y,99),%X=$S(%Y=16:12.1,%Y=10!(%Y=12):5,1:"") G QLTY:'%X 10 S %Y=$S($D(^%ZIS(2,%ZISIOST(0),%X)):$P(^(%X),"^",$S(%Y=12:2,1:1)),1:"") 11 I %Y]"" W @%Y 12 QLTY S %Y=$F(IO("P"),"Q") Q:'%Y S %Y=+$E(IO("P"),%Y,99),%X=$S(%Y<0!(%Y>2):0,1:%Y+1) 13 I %X S %Y=$S($D(^%ZIS(2,%ZISIOST(0),12.2)):$P(^(12.2),"^",%X),1:"") I %Y]"" W @%Y 14 QUIT U:%IS'[0 IO(0) 15 Q 16 2 Q:%Y="" I %IS'[0,$D(^%ZIS(1,+%H,"TYPE")),^("TYPE")["TRM" D OH Q:POP 17 S %X=$T U IO D %Y^ZISX ;Q:'%X U IO(0) 18 Q 19 OH Q:$S($G(IO(0))]"":$D(IO(1,IO(0))),1:0) 20 N X S X="OPNERR^%ZIS4",@^%ZOSF("TRAP") 21 O IO(0)::0 S IO(1,IO(0))="" Q ;See that HOME DEVICE is open. 22 ; 23 SAY(%SAY) ; 24 Q:%IS[0 U IO(0) W %SAY U IO 25 Q 26 RES1 ;Allocate a resource slot, Release in %ZISC. 27 N A,L,X,%ZISD0 28 S %ZISD0=$O(^%ZISL(3.54,"B",IO,0)) 29 I '%ZISD0 S %ZISD0=$$RADD(IO) ;New one 30 L +^%ZISL(3.54,%ZISD0,0):2 I '$T S POP=1 W:'$D(IOP) *7," [NOT Available]" G RESX 31 RES2 S X=$P(^%ZISL(3.54,%ZISD0,0),"^",2) 32 I X<1 S POP=1 W:'$D(IOP) *7," [NOT Available]" G RESX 33 S X=$S(X>0:X-1,1:0),$P(^%ZISL(3.54,%ZISD0,0),"^",2)=X 34 ; 35 R1 ;Grab a slot 36 S IO(1,IO)="RES",A=$G(^%ZISL(3.54,%ZISD0,1,0),"^3.542^^") 37 F L=1:1:%ZISRL I '$D(^%ZISL(3.54,%ZISD0,1,L,0)) Q 38 I '$T K IO(1,IO) G RES2 ;No free slots 39 S ^%ZISL(3.54,%ZISD0,1,L,0)=L_"^"_%ZISV_"^"_$J_"^"_$G(ZTSK)_"^"_$H,^%ZISL(3.54,"AJ",$J,%ZISD0,L)="",^%ZISL(3.54,%ZISD0,1,"B",L,L)="" 40 S $P(A,"^",3,4)=L_U_($P(A,U,4)+1),^%ZISL(3.54,%ZISD0,1,0)=A 41 RESX L -^%ZISL(3.54,%ZISD0,0) Q 42 ; 43 RADD(X) ;Add Resource 44 N %1,%2 45 S %1=$G(^%ZISL(3.54,0),"RESOURCE^3.54^^"),%2=$P(%1,U,3) 46 F %2=%2:1 Q:'$D(^%ZISL(3.54,%2,0)) 47 S $P(^%ZISL(3.54,0),U,3,4)=%2_U_($P(%1,U,4)+1),^%ZISL(3.54,%2,0)=X_"^"_$G(%ZISRL,1),^%ZISL(3.54,"B",X,%2)="" 48 Q %2 49 ; 50 RESOK ;DEVOK check for RES devices, for all OS's. 51 N %ZISD0,%ZISD1 52 S Y=0,%ZISD0=$O(^%ZISL(3.54,"B",X,0)) 53 I '%ZISD0 S Y=-1,%ZISD0=$O(^%ZIS(1,"C",X,0)) Q:'%ZISD0 Q:'$D(^%ZIS(1,+%ZISD0,0)) Q:$P(^(0),"^")'=X Q:'$D(^("TYPE")) Q:^("TYPE")'="RES" S Y=0 Q 54 S X1=$G(^%ZISL(3.54,+%ZISD0,0)) 55 I $P(X1,"^",2)&(X=$P(X1,"^")) S Y=0 Q 56 S Y=999 F %ZISD1=0:0 S %ZISD1=$O(^%ZISL(3.54,%ZISD0,1,%ZISD1)) Q:%ZISD1'>0 I $D(^(%ZISD1,0)) S Y=$P(^(0),"^",3) Q 57 Q 58 ; 59 Q G Q^%ZIS3 60 HG ; 61 Q 62 SPL N %E,%Z D MARGN^%ZIS3 W:'$D(IOP) ! D SPOOL^%ZIS4:%IS'["T" ;Spool type 63 G Q 64 MT D MARGN^%ZIS3,ASKPAR,AMTREW:'POP&'$D(IOP)&%ZISB W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T")) ;Magtape type 65 G Q 66 SDP D MARGN^%ZIS3,ASKPAR W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T")) ;Sequential disk processor type 67 G Q 68 HFS D MARGN^%ZIS3,HFS^%ZIS4 W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T")) ;Host File Server type 69 G Q 70 RES G Q:%IS["T" N X,X1 I %IS'["R"!'$D(IOP) S POP=1 W:'$D(IOP) *7," [NOT AVAILABLE]" Q ;Resources 71 G Q:$D(IO(1,IO)) I %IS["T" S X=IO,X1="RES" D DEVOK^%ZIS3 S:Y POP=1 G Q:POP 72 D:%ZISB RES1 G Q 73 CHAN ;Network Channel type devices -- DecNet or TCP/IP devices. 74 I IO="SYS$NET",$I="SYS$INPUT:;" S IO(0)=IO U IO ;DECNET Server Device 75 D MARGN^%ZIS3:'POP,ASKPAR:'POP W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T")) 76 G Q 77 IMPC ;Imaging Work Station 78 BAR ;Bar Code 79 OTH D MARGN^%ZIS3:'POP,ASKPAR:'POP W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T")) ;Other Device type 80 G Q 81 ; 82 ASKPAR G SETPAR^%ZIS3:$D(IOP),SETPAR^%ZIS3:'$P(^%ZIS(1,%E,0),"^",4) W " ADDRESS/PARAMETERS: " W:%ZISOPAR]"" %ZISOPAR_"// " D SBR^%ZIS1 D MSG1:%X="?" G ASKPAR:%X="?" S:%X]"" %ZISOPAR=%X I $D(DTOUT)!$D(DUOUT) S POP=1 83 I POP,%ZISB&(%ZTYPE["TRM") C IO K IO(1,IO) Q 84 Q:POP G SETPAR^%ZIS3 85 AMTREW I %ZISB,%ZTYPE="MT",'$D(IOP) W " REWIND" S %=2,U="^",%ZISDTIM=60 D YN^%ZIS1 K %ZISDTIM G AMTREW:%=0 I %=-1 S POP=1 Q 86 S:%=1 %ZISMTR=1 Q 87 MSG1 W !?5,"Enter the desired parameters needed to open the selected device.",!?25 Q 88 ; -
WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZISC.m
r613 r623 1 %ZISC ;SFISC/GFT,AC,MUS - CLOSE LOGIC FOR DEVICES ;1/24/08 16:09 2 ;;8.0;KERNEL;**24,36,49,69,199,216,275,409,440**;JUL 10, 1995;Build 13 3 ;Per VHA Directive 2004-038, this routine should not be modified 4 C0 ; 5 N %,%E,%H,%ZISI,%ZISOS,%ZISX,%ZISV 6 ;Clear IO var we will use for reporting 7 K IO("ERROR"),IO("LASTERR"),IO("CLOSE") 8 ;Protect ourself from calls with incomplete setup. 9 S:$D(IO)[0 IO=$I S:'$D(IO(0)) IO(0)=$P 10 S U="^",%ZISOS=$G(^%ZOSF("OS")),%ZISV=$G(^("VOL")) 11 ;S %=$S(+$G(IOS):IOS,$L($G(ION)):ION,1:IO) 12 S %=$S($L($G(ION)):ION,1:IO) ;p409 13 I (%="")!(IO="") G SETIO:IO(0)]"",END 14 I $G(IOT)="RES" D RES G SETIO ;Handle a resource device 15 ; 16 ;Define subtype info if not already defined. 17 D SUBTYPE 18 ; 19 ;perform close execute 20 I $G(IOST(0))>0 D 21 . I $G(^%ZIS(2,+IOST(0),3))]"",$D(IO(1,IO)) D 22 . . U IO S:$X $X=1 D X3^ZISX:'$D(IO("T")) 23 ; 24 ;Incase the Close execute changed IO, Open IO("HOME") or NULL. 25 I '$L($G(IO)) D Q 26 . S IOP=$S($L($G(IO("HOME"))):"`"_(+IO("HOME")),1:"NULL") D ^%ZIS 27 . Q 28 ; 29 ;Perform the following if the device is open. 30 I $D(IO(1,IO)) D 31 . I $G(IO("P"))["B" D ;Return to normal intensity 32 . . S %=$P($G(^%ZIS(2,+IOST(0),7)),"^",3) I %]"" W @% 33 . I $G(IO("P"))["P" D ;Return to default pitch 34 . . S %=$G(^%ZIS(2,+IOST(0),12.11)) I %]"" W @% 35 . ; 36 . W:$$FF @IOF ;Issue form feed at close 37 . I $$CLOSPP D X11^ZISX:'$D(IO("T")) K IO("S") ;Close printer port 38 . Q 39 ; 40 ;Don't use IOCPU as we now use IO(1,IO) 41 I (IO'=IO(0)!$D(IO("C"))),$D(IO(1,IO)) D 42 . U:$S($D(ZTQUEUED):0,'$L($G(IO(0))):0,$D(IO(1,IO(0)))#2:1,1:0) IO(0) 43 . C IO K IO(1,IO) S IO("CLOSE")=IO ;close device 44 ;Unlock global used to control access. 45 S %=$G(^XUTL("XQ",$J,"lock",+$G(IOS))) I $L(%) L -@% K ^XUTL("XQ",$J,"lock",IOS) 46 ; 47 I $D(IO("SPOOL")) D CLOSE^%ZIS4 ;Special close for spool device 48 ; 49 SETIO ; 50 ;See if old device has PCX code 51 I $G(IOS),$G(^%ZIS(1,+IOS,"PCX"))]"" S %ZISPCX=^("PCX") 52 ;Setup the IO(0) device, should be the home device 53 S IO=IO(0),(IOPAR,IOUPAR)="" K IO("T") D CIOS(IO(0)) 54 I 'IOS S IOT="TRM" G END 55 S ION=$P(^%ZIS(1,IOS,0),"^",1),IOT=$G(^("TYPE")),IOST(0)=$S(IOT["TRM"&($D(^XUTL("XQ",$J,"IOST(0)"))):^("IOST(0)"),1:$G(^%ZIS(1,IOS,"SUBTYPE"))) 56 I IOT["TRM",$D(^XUTL("XQ",$J,"IO")) D HOME^%ZIS G END 57 S %="Y" 58 I IOST(0),$D(^%ZIS(2,IOST(0),1)) S %=^(1),IOM=+%,IOF=$P(%,"^",2),IOSL=$P(%,"^",3),IOBS=$P(%,"^",4) 59 I $D(^%ZIS(1,IOS,91)) S %=^%ZIS(1,IOS,91) S:+% IOM=+% S:$P(%,"^",3) IOSL=$P(%,"^",3) 60 ;Don't know the subtype so set some defaults 61 I %="Y" S IOM=80,IOSL=24,IOF="#",IOST="C-OTHER",IOBS="$C(8)" 62 S1 S:IOST(0) IOST=$P($G(^%ZIS(2,+IOST(0),0)),"^"),IOXY=$G(^("XY")) 63 I '$D(ZTQUEUED),'$D(IO("C")),IOT["TRM" D RM:$D(IO(1,IO)) 64 ;With home device set, Do Post-close execute code of Device closed. 65 END I '$D(IO("T")),$G(%ZISPCX)]"" S %Y=%ZISPCX D %Y^ZISX 66 ;See that any extra IO variables are cleaned up 67 K IO("P"),IO("DOC"),IO("HFSIO"),IO("SPOOL"),IOC,IONOFF 68 ;IOCPU should not be changed. 69 Q 70 ; 71 SUBTYPE ;Find a subtype 72 N %S 73 S IOST=$G(IOST),IOST(0)=+$G(IOST(0)) 74 I $L(IOST)&$L(IOST(0)) Q ;Have a subtype 75 S %S=$G(^%ZIS(2,+IOST(0),0)) I $L(%S) S IOST=$P(%S,U) Q 76 I $L(IOST) S %S=$O(^%ZIS(2,"B",$G(IOST,"X"),0)) I %S>0 S IOST(0)=+%S Q 77 S IOST="",IOST(0)=0 D CIOS($I) Q:IOS'>0 78 S IOST(0)=$G(^%ZIS(1,+IOS,"SUBTYPE")),IOST=$P($G(^%ZIS(2,+IOST(0),0)),"^") 79 Q 80 ; 81 CIOS(%I) ;Find a value for IOS (IEN into device file) 82 N %ZISVT 83 I $D(^XUTL("XQ",$J,"IOS")) S IOS=+^("IOS") Q 84 I $D(%ZISV) S %ZISVT=%I D VTLKUP^%ZIS S IOS=+%E 85 E S IOS=+$O(^%ZIS(1,"C",%I,0)) 86 Q:$G(IOS)>0 87 S %ZISVT=%I D VIRTUAL^%ZIS 88 I $D(%ZISVT) S %H=%E I %ZISVT]"",%H>0,$D(^%ZIS(1,%H,0)),$D(^("TYPE")),^("TYPE")="VTRM" S IOS=%H 89 Q 90 ; 91 RM N X S X=+IOM X ^%ZOSF("RM") 92 Q 93 ; 94 RES ;Close resource device. 95 Q:'$D(IO(1,IO))&'$D(^%ZISL(3.54,"AJ",$J)) 96 N %ZISJOB,%X,%Y,%ZISD0,%ZISD1,%ZISRES,%ZISRL,%ZISY0,%ZTRTN,ZTSAVE,ZTIO 97 S %ZISJOB=$J 98 ; 99 RES1 G RQ:'$D(IOS),RQ:'$D(^%ZIS(1,+IOS,1)) S %ZISRL=+$P(^(1),"^",10),%ZISRL=$S(%ZISRL:%ZISRL,1:1) 100 S %X=$O(^%ZISL(3.54,"B",IO,0)) G RQ:'%X 101 G RQ:'$D(^%ZISL(3.54,+%X,0)) S %ZISD0=+%X,%ZISY0=^(0) 102 S %X=$O(^%ZISL(3.54,"AJ",%ZISJOB,%ZISD0,0)) S %ZISD1=%X G RQ:'%X 103 S %Y=$G(^%ZISL(3.54,%ZISD0,1,+%ZISD1,0)) G RQ:$P(%Y,"^",3)'=%ZISJOB 104 D KILLRES(+%ZISD0,+%ZISD1) 105 RQ K IO(1,IO) 106 Q 107 ; 108 KILLRES(D0,D1) ;Kill one resource use 109 Q:(D0'>0)!(D1'>0) 110 N %X,%Y,%J,%ZISRL 111 L +^%ZISL(3.54,D0,0) 112 S %Y=$G(^%ZISL(3.54,D0,0)) G KRX:%Y="" 113 S %X=$G(^%ZISL(3.54,D0,1,D1,0)),%J=$P(%X,"^",3) S:%J="" %J=" " 114 K ^%ZISL(3.54,D0,1,D1,0),^%ZISL(3.54,D0,1,"B",D1,D1),^%ZISL(3.54,"AJ",%J,D0,D1) 115 S %X=$P(%Y,"^",2)+1,$P(^%ZISL(3.54,D0,0),"^",2)=%X 116 ;I '$D(^%ZISL(3.54,%ZISD0,1,0)) S ^(0)="^3.542A^^" G RQ 117 S %Y=$G(^%ZISL(3.54,D0,1,0)),%X=$P(%Y,"^",4),$P(^%ZISL(3.54,D0,1,0),"^",3,4)="^"_$S(%X>0:(%X-1),1:0) 118 KRX L -^%ZISL(3.54,D0,0) 119 Q 120 ; 121 DQCRES ;Tasked entry point to close resource device. 122 S IO=%ZISRES G RES1 123 ; 124 FF() ;Issue form feed 125 I $E(IOST,1,2)'["C-",$D(IO(1,IO)),$G(IOT)="TRM"!($G(IOT)="SPL"),'$D(IO("T"))&$Y&'$D(IONOFF)&'$D(IO(1,IO,"NOFF")) Q 1 126 Q 0 127 ; 128 CLOSPP() ;Close printer port 129 I $D(IO("S")),$D(^%ZIS(2,+IO("S"),11))&$D(IO(1,IO)) Q 1 130 Q 0 1 %ZISC ;SFISC/GFT,AC,MUS - CLOSE LOGIC FOR DEVICES ;01/14/2002 09:06 2 ;;8.0;KERNEL;**24,36,49,69,199,216,275,409**;JUL 10, 1995;Build 3 3 C0 ; 4 N %,%E,%H,%ZISI,%ZISOS,%ZISX,%ZISV 5 ;Clear IO var we will use for reporting 6 K IO("ERROR"),IO("LASTERR"),IO("CLOSE") 7 ;Protect ourself from calls with incomplete setup. 8 S:$D(IO)[0 IO=$I S:'$D(IO(0)) IO(0)=$P 9 S U="^",%ZISOS=$G(^%ZOSF("OS")),%ZISV=$G(^("VOL")) 10 ;S %=$S(+$G(IOS):IOS,$L($G(ION)):ION,1:IO) 11 S %=$S($L($G(ION)):ION,1:IO) ;p409 12 I (%="")!(IO="") G SETIO:IO(0)]"",END 13 I $G(IOT)="RES" D RES G SETIO ;Handle a resource device 14 ; 15 ;Define subtype info if not already defined. 16 D SUBTYPE 17 ; 18 ;perform close execute 19 I $G(IOST(0))>0 D 20 . I $G(^%ZIS(2,+IOST(0),3))]"",$D(IO(1,IO)) D 21 . . U IO S:$X $X=1 D X3^ZISX:'$D(IO("T")) 22 ; 23 ;Incase the Close execute changed IO, Open IO("HOME") or NULL. 24 I '$L($G(IO)) D Q 25 . S IOP=$S($L($G(IO("HOME"))):"`"_(+IO("HOME")),1:"NULL") D ^%ZIS 26 . Q 27 ; 28 ;Perform the following if the device is open. 29 I $D(IO(1,IO)) D 30 . I $G(IO("P"))["B" D ;Return to normal intensity 31 . . S %=$P($G(^%ZIS(2,+IOST(0),7)),"^",3) I %]"" W @% 32 . I $G(IO("P"))["P" D ;Return to default pitch 33 . . S %=$G(^%ZIS(2,+IOST(0),12.11)) I %]"" W @% 34 . ; 35 . W:$$FF @IOF ;Issue form feed at close 36 . I $$CLOSPP D X11^ZISX:'$D(IO("T")) K IO("S") ;Close printer port 37 . Q 38 ; 39 ;Don't use IOCPU as we now use IO(1,IO) 40 I (IO'=IO(0)!$D(IO("C"))),$D(IO(1,IO)) D 41 . U:$S($D(ZTQUEUED):0,'$L($G(IO(0))):0,$D(IO(1,IO(0)))#2:1,1:0) IO(0) 42 . C IO K IO(1,IO) S IO("CLOSE")=IO ;close device 43 ; 44 ; 45 I $D(IOT),IOT="CHAN",$D(IOS) D 46 .S %=$G(^%ZIS(1,+IOS,"GBL")) 47 .I %]"" L @("-^"_%) ;unlock global used to control access to network channels. 48 I $D(IO("SPOOL")) D CLOSE^%ZIS4 ;Special close for spool device 49 ; 50 SETIO ; 51 ;See if old device has PCX code 52 I $G(IOS),$G(^%ZIS(1,+IOS,"PCX"))]"" S %ZISPCX=^("PCX") 53 ;Setup the IO(0) device, should be the home device 54 S IO=IO(0),(IOPAR,IOUPAR)="" K IO("T") D CIOS(IO(0)) 55 I 'IOS S IOT="TRM" G END 56 S ION=$P(^%ZIS(1,IOS,0),"^",1),IOT=$G(^("TYPE")),IOST(0)=$S(IOT["TRM"&($D(^XUTL("XQ",$J,"IOST(0)"))):^("IOST(0)"),1:$G(^%ZIS(1,IOS,"SUBTYPE"))) 57 I IOT["TRM",$D(^XUTL("XQ",$J,"IO")) D HOME^%ZIS G END 58 S %="Y" 59 I IOST(0),$D(^%ZIS(2,IOST(0),1)) S %=^(1),IOM=+%,IOF=$P(%,"^",2),IOSL=$P(%,"^",3),IOBS=$P(%,"^",4) 60 I $D(^%ZIS(1,IOS,91)) S %=^%ZIS(1,IOS,91) S:+% IOM=+% S:$P(%,"^",3) IOSL=$P(%,"^",3) 61 ;Don't know the subtype so set some defaults 62 I %="Y" S IOM=80,IOSL=24,IOF="#",IOST="C-OTHER",IOBS="$C(8)" 63 S1 S:IOST(0) IOST=$P($G(^%ZIS(2,+IOST(0),0)),"^"),IOXY=$G(^("XY")) 64 I '$D(ZTQUEUED),'$D(IO("C")),IOT["TRM" D RM:$D(IO(1,IO)) 65 ;With home device set, Do Post-close execute code of Device closed. 66 END I '$D(IO("T")),$G(%ZISPCX)]"" S %Y=%ZISPCX D %Y^ZISX 67 ;See that any extra IO variables are cleaned up 68 K IO("P"),IO("DOC"),IO("HFSIO"),IO("SPOOL"),IOC,IONOFF 69 ;IOCPU should not be changed. 70 Q 71 ; 72 SUBTYPE ;Find a subtype 73 N %S 74 S IOST=$G(IOST),IOST(0)=+$G(IOST(0)) 75 I $L(IOST)&$L(IOST(0)) Q ;Have a subtype 76 S %S=$G(^%ZIS(2,+IOST(0),0)) I $L(%S) S IOST=$P(%S,U) Q 77 I $L(IOST) S %S=$O(^%ZIS(2,"B",$G(IOST,"X"),0)) I %S>0 S IOST(0)=+%S Q 78 S IOST="",IOST(0)=0 D CIOS($I) Q:IOS'>0 79 S IOST(0)=$G(^%ZIS(1,+IOS,"SUBTYPE")),IOST=$P($G(^%ZIS(2,+IOST(0),0)),"^") 80 Q 81 ; 82 CIOS(%I) ;Find a value for IOS (IEN into device file) 83 N %ZISVT 84 I $D(^XUTL("XQ",$J,"IOS")) S IOS=+^("IOS") Q 85 I $D(%ZISV) S %ZISVT=%I D VTLKUP^%ZIS S IOS=+%E 86 E S IOS=+$O(^%ZIS(1,"C",%I,0)) 87 Q:$G(IOS)>0 88 S %ZISVT=%I D VIRTUAL^%ZIS 89 I $D(%ZISVT) S %H=%E I %ZISVT]"",%H>0,$D(^%ZIS(1,%H,0)),$D(^("TYPE")),^("TYPE")="VTRM" S IOS=%H 90 Q 91 ; 92 RM N X S X=+IOM X ^%ZOSF("RM") 93 Q 94 ; 95 RES ;Close resource device. 96 Q:'$D(IO(1,IO))&'$D(^%ZISL(3.54,"AJ",$J)) 97 N %ZISJOB,%X,%Y,%ZISD0,%ZISD1,%ZISRES,%ZISRL,%ZISY0,%ZTRTN,ZTSAVE,ZTIO 98 S %ZISJOB=$J 99 ; 100 RES1 G RQ:'$D(IOS),RQ:'$D(^%ZIS(1,+IOS,1)) S %ZISRL=+$P(^(1),"^",10),%ZISRL=$S(%ZISRL:%ZISRL,1:1) 101 S %X=$O(^%ZISL(3.54,"B",IO,0)) G RQ:'%X 102 G RQ:'$D(^%ZISL(3.54,+%X,0)) S %ZISD0=+%X,%ZISY0=^(0) 103 S %X=$O(^%ZISL(3.54,"AJ",%ZISJOB,%ZISD0,0)) S %ZISD1=%X G RQ:'%X 104 S %Y=$G(^%ZISL(3.54,%ZISD0,1,+%ZISD1,0)) G RQ:$P(%Y,"^",3)'=%ZISJOB 105 D KILLRES(+%ZISD0,+%ZISD1) 106 RQ K IO(1,IO) 107 Q 108 ; 109 KILLRES(D0,D1) ;Kill one resource use 110 Q:(D0'>0)!(D1'>0) 111 N %X,%Y,%J,%ZISRL 112 L +^%ZISL(3.54,D0,0) 113 S %Y=$G(^%ZISL(3.54,D0,0)) G KRX:%Y="" 114 S %X=$G(^%ZISL(3.54,D0,1,D1,0)),%J=$P(%X,"^",3) S:%J="" %J=" " 115 K ^%ZISL(3.54,D0,1,D1,0),^%ZISL(3.54,D0,1,"B",D1,D1),^%ZISL(3.54,"AJ",%J,D0,D1) 116 S %X=$P(%Y,"^",2)+1,$P(^%ZISL(3.54,D0,0),"^",2)=%X 117 ;I '$D(^%ZISL(3.54,%ZISD0,1,0)) S ^(0)="^3.542A^^" G RQ 118 S %Y=$G(^%ZISL(3.54,D0,1,0)),%X=$P(%Y,"^",4),$P(^%ZISL(3.54,D0,1,0),"^",3,4)="^"_$S(%X>0:(%X-1),1:0) 119 KRX L -^%ZISL(3.54,D0,0) 120 Q 121 ; 122 DQCRES ;Tasked entry point to close resource device. 123 S IO=%ZISRES G RES1 124 ; 125 FF() ;Issue form feed 126 I $E(IOST,1,2)'["C-",$D(IO(1,IO)),$G(IOT)="TRM"!($G(IOT)="SPL"),'$D(IO("T"))&$Y&'$D(IONOFF)&'$D(IO(1,IO,"NOFF")) Q 1 127 Q 0 128 ; 129 CLOSPP() ;Close printer port 130 I $D(IO("S")),$D(^%ZIS(2,+IO("S"),11))&$D(IO(1,IO)) Q 1 131 Q 0 -
WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZISEDIT.m
r613 r623 1 ZISEDIT ;ISF/AC - DEVICE EDIT ;01/17/2008 2 ;;8.0;KERNEL;**440**;Jul 10, 1995;Build 13 3 ; 4 TRM ;TRM or VTRM 5 D EDIT("TRM",,"Select Terminal/Printer Device: ") 6 Q 7 ; 8 LPD ;LPD fields of a TRM device 9 D EDIT("LPD","TRM","Select LPD (Terminal/Printer) Device: ") 10 Q 11 ; 12 MT ;Mag Tape 13 D EDIT("MT",,"Select Magtape Device: ") 14 Q 15 ; 16 SDP ; 17 D EDIT("SDP",,"Select SDP Device: ") 18 Q 19 ; 20 SPL ;Spool 21 D EDIT("SPL",,"Select Spool Device: ") 22 Q 23 ; 24 HFS ;Host file 25 D EDIT("HFS",,"Select Host File Device: ") 26 Q 27 ; 28 CHAN ;Network 29 D EDIT("CHAN",,"Select Network Channel: ") 30 Q 31 ; 32 RES ;Resource 33 D EDIT("RES",,"Select Resource Device: ") 34 Q 35 ; 36 EDIT(ZISTYPE,ZISSCR,DICA) ; 37 N Y,DA,DIC,DIE,DR,DDSFILE 38 ED2 S DIC("A")=DICA,ZISSCR=$G(ZISSCR,ZISTYPE) 39 S DIC=3.5,DIC(0)="AEMQZL",DIC("S")="I $G(^(""TYPE""))["_""""_ZISSCR_"""" D ^DIC 40 Q:Y'>0 41 S DA=+Y 42 I $P(Y,"^",3) D 43 . N DIE,DR 44 . S DIE=DIC,DR="2///"_ZISTYPE_$S(ZISTYPE["TRM":"",1:";1.95///N") 45 . D ^DIE 46 . Q 47 S DR="[XUDEVICE "_ZISTYPE_"]",DDSFILE=3.5 D ^DDS 48 G ED2 49 Q 1 ZISEDIT ;SFISC/AC - DEVICE EDIT ;11/9/92 17:00 2 ;;8.0;KERNEL;;Jul 10, 1995 3 ; 4 MT S ZISTYPE="MT",DIC("A")="Select Magtape Device: " D EDIT K ZISTYPE 5 Q 6 ; 7 SDP S ZISTYPE="SDP",DIC("A")="Select SDP Device: " D EDIT K ZISTYPE 8 Q 9 ; 10 SPL S ZISTYPE="SPL",DIC("A")="Select Spool Device: " D EDIT K ZISTYPE 11 Q 12 ; 13 HFS S ZISTYPE="HFS",DIC("A")="Select Host File Device: " D EDIT K ZISTYPE 14 Q 15 ; 16 CHAN S ZISTYPE="CHAN",DIC("A")="Select Network Channel: " D EDIT K ZISTYPE 17 Q 18 ;;7.1P0;Kernel;; 19 EDIT S DIC=3.5,DIC(0)="AEMQZL",DIC("S")="I $G(^(""TYPE""))="_""""_ZISTYPE_"""" D ^DIC 20 I Y'>0 K DIC Q 21 S DA=+Y I $P(Y,"^",3) S DIE=DIC,DR="2///"_ZISTYPE D ^DIE K DIE,DR 22 S DR="[XUDEVICE "_ZISTYPE_"]",DDSFILE=3.5 D ^DDS 23 K DA,DR,DDSFILE Q -
WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZISHONT.m
r613 r623 1 %ZISH ;IHS/PR,SFISC/AC - Host File Control for Cache for VMS/NT/UNIX ;1/24/08 16:11 2 ;;8.0;KERNEL;**34,65,84,104,191,306,385,440**;JUL 10, 1995;Build 13 3 ;Per VHA Directive 2004-038, this routine should not be modified 4 ; **MODIFIED VERSION FOR CACHE/VMS -- 9/7/01** 5 ; 6 OPEN(X1,X2,X3,X4,X5,X6) ;SR. Open Host File 7 ;X1=handle name 8 ;X2=directory name \dir\ 9 ;X3=file name 10 ;X4=file access mode e.g.: W for write, R for read, A for append. 11 ;X5=Max record size for a new file, X6=Subtype 12 N %,%1,%2,%I,%ZOS,%T,%ZA,%ZISHIO,$ET 13 S $ET="D OPNERR^%ZISH" 14 S U="^",%I=$I,%T=0,POP=0,X2=$$DEFDIR($G(X2)),%ZOS=$$OS^%ZOSV M %ZISHIO=IO 15 I %ZOS'="VMS" S %1=$S(X4["A":"AW",X4["W":"WN",1:"R")_$S(X4["B":"U",1:"S") ;NT & Unix 16 I %ZOS="VMS" S %1=$S(X4["A":"AW",X4["W":"WN",1:"RH")_$S(X4["B":"U",1:"S") 17 ;The next line eliminates the <ENDOFFILE> error for sequential files for the current process. 18 S %ZA=$ZUTIL(68,40,1) ;Work like DSM 19 S %=X2_X3 O %:(%1):2 I '$T S POP=1 Q 20 ;U % S %ZA=$ZA ;Comment out, $ZA is for READ status 21 ;I %ZA=-1 U:%I]"" %I C % S POP=1 Q 22 S IO=%,IO(1,IO)="",IOT="HFS",IOM=80,IOSL=60,POP=0 D SUBTYPE^%ZIS3($G(X6,"P-OTHER")) 23 I $G(X1)]"" D SAVDEV^%ZISUTL(X1) 24 U $S(%I]"":%I,1:$P) 25 Q 26 ; 27 OPNERR ;Handle open error 28 S POP=1,$ECODE="" 29 U:$P]"" $P 30 Q 31 ; 32 CLOSE(X) ;SR. Close HFS device not opened by %ZIS. 33 ;X=HANDLE NAME 34 ;IO=Device 35 N % 36 I $G(IO)]"" C IO K IO(1,IO) 37 I $G(X)]"" D RMDEV^%ZISUTL(X) 38 ;Only reset home if one setup. 39 I $D(IO("HOME"))!$D(^XUTL("XQ",$J,"IOS")) D HOME^%ZIS 40 Q 41 ; 42 OPENERR ; 43 Q 0 44 ; 45 DEL(%ZX1,%ZX2) ;ef,SR. Del files, return 1 if deleted all requested. 46 ;S Y=$$DEL^%ZISH("dir path",$NA(array)) 47 ; will invoke an OS command to delete file(s) 48 ; UNIX: rm -f filespec[ ...] 49 ; VMS: del filespec[,...] 50 N %ZARG,%ZXDEL,%ZOS,%ZDELIM,%ZCOMND,%ZLIST 51 S %ZARG="",%ZXDEL=1 52 S %ZX1=$$DEFDIR($G(%ZX1)) 53 S %ZOS=$$OS^%ZOSV 54 S %ZDELIM=$S(%ZOS="UNIX":" ",1:",") 55 S %ZCOMND=$S(%ZOS="UNIX":"rm -f ",1:"del ") 56 D 57 . N $ETRAP,$ESTACK S $ETRAP="D DELERR^%ZISH" 58 . N %,%ZI,%ZISH,%ZX,%ZFOUND S %ZISH="" 59 . F %ZI=1:1 S %ZISH=$O(@%ZX2@(%ZISH)) Q:%ZISH="" D 60 . . N $ETRAP,$ESTACK S $ETRAP="D DELERR^%ZISH" 61 . . I %ZISH["*" S %ZXDEL=0 Q ; Wild card not allowed. 62 . . S %ZX=$S(%ZISH[%ZX1:%ZISH,1:%ZX1_%ZISH) ; prepend directory path 63 . . I %ZOS="VMS",%ZX'[";" S %ZX=%ZX_";*" 64 . . S %ZFOUND=$ZSEARCH(%ZX)]"" ; File exists 65 . . S:%ZFOUND %ZARG=$S(%ZARG="":%ZX,1:%ZARG_%ZDELIM_%ZX) ; join files 66 . . I $L(%ZARG)>2000 S %=$ZF(-1,%ZCOMND_%ZARG),%ZARG="" H 1 ; delete files at a time 67 . ; 68 . I $L(%ZARG) S %=$ZF(-1,%ZCOMND_%ZARG) ; delete remaining files 69 ; 70 I %ZXDEL S %ZXDEL='$$LIST(%ZX1,%ZX2,"%ZLIST") 71 Q %ZXDEL 72 ; 73 DELERR ;Trap any $ETRAP error, unwind and return. 74 S $ETRAP="D UNWIND^%ZTER" 75 S %ZXDEL=0,%ZARG="" 76 D UNWIND^%ZTER 77 Q 78 ; 79 DEL1(%ZX3) ;ef,SR. Delete one file 80 N %ZI1,%ZI2 81 D SPLIT(%ZX3,.%ZI1,.%ZI2) S %ZI2(%ZI2)="" 82 Q $$DEL(%ZI1,$NA(%ZI2)) 83 ; 84 SPLIT(%I,%O1,%O2) ;Split to path,file 85 N %ZOS,%D,D S %ZOS=$$OS^%ZOSV 86 I %ZOS["VMS" D Q 87 . S D=$S(%I["]":"]",1:":") 88 . S %O1=$P(%I,D,1)_D,%O2=$P(%I,D,2) 89 . Q 90 S %D=$S(%ZOS="UNIX":"/",%ZOS="NT":"\",1:""),%O1="",%O2="" Q:%D="" 91 S D=$L(%I,%D),%O1=$P(%I,%D,1,D-1),%O2=$P(%I,%D,D) 92 Q 93 ; 94 FEXIST(%PATH,%FL) ;Check if files exsist. 95 ;S Y=$$DTEST("/usr/var",$NA(array)) 96 N %ZISH,%ZISHY 97 S %ZISH=$$LIST(%PATH,%FL,"%ZISHY") 98 Q %ZISH 99 ; 100 LIST(%ZX1,%ZX2,%ZX3) ;ef,SR. Create a local array holding file names 101 ;S Y=$$LIST^%ZISH("\dir\",$NA(array),$NA(return array)) Return 1 if found anything 102 ; 103 N %ZISH,%ZISHN,%ZX,%ZISHY,%ZY,%ZOS 104 S %ZX1=$$DEFDIR($G(%ZX1)),%ZOS=$$OS^%ZOSV 105 ;S %ZX1=$$TRNLNM(%ZX1) 106 ;Get fls to act on 107 S %ZISH="" F S %ZISH=$O(@%ZX2@(%ZISH)) Q:%ZISH="" D 108 . S %ZISHY=$P(%ZISH,"*") 109 . I %ZOS="VMS",%ZISH'["." S %ZISH=%ZISH_".*" ;Allways upper 110 . ;NT, display case, ignore for lookup 111 . S %ZX=%ZX1_%ZISH 112 . F %ZISHN=0:1 D Q:(%ZX="") 113 . . S %ZX=$ZSEARCH($S(%ZISHN:"",1:%ZX)) 114 . . ;Q:(%ZX="")!($$UP^XLFSTR(%ZX)'[%ZISHY)!(%ZX?.E1.2".") 115 . . Q:(%ZX="")!(%ZX?.E1.2".") 116 . . I %ZOS="VMS" S %ZX=$P(%ZX,"]",2),@%ZX3@(%ZX)="" 117 . . I %ZOS="NT" S %ZY=$P(%ZX,"\",$L(%ZX,"\")),@%ZX3@(%ZY)="" 118 . . I %ZOS="UNIX" S %ZY=$P(%ZX,"/",$L(%ZX,"/")) Q:%ZX'[%ZISHY S @%ZX3@(%ZY)="" 119 . . Q 120 Q $O(@%ZX3@(""))]"" 121 ; 122 MV(X1,X2,Y1,Y2) ;ef,SR. Rename a fl 123 ;S Y=$$MV^ZOSHDOS("\dir\","fl","\dir\","fl") 124 ;Unix use mv, NT/VMS use COPY and DEL 125 N %,X,Y,%ZOS,%ZISHX S %ZOS=$$OS^%ZOSV 126 S X1=$$DEFDIR($G(X1)),Y1=$$DEFDIR($G(Y1)) 127 S X=$ZSEARCH(X1_X2),Y=Y1_Y2 ;move X to Y 128 I X="" Q 0 129 S %=$ZF(-1,$S(%ZOS="UNIX":"mv ",1:"copy ")_X_" "_Y) ;Use NT/VMS copy 130 I %ZOS'="UNIX" D 131 . S X2=$P(X,X1,2),%ZISHX(X2)="" 132 . S Y=$$DEL^%ZISH(X1,$NA(%ZISHX)) 133 Q 1 134 ; 135 PWD() ;ef,SR. Print working directory 136 N Y,%ZOS 137 S Y=$$DEFDIR(""),%ZOS=$$OS^%ZOSV 138 I Y="" S Y=$ZSEARCH("*") 139 Q $S(%ZOS["VMS":Y,1:$P(Y,".",1)) 140 ; 141 TRNLNM(PATH) ;ef. Expand logical path 142 N %ZOS,P1,P2 143 S %ZOS=$$OS^%ZOSV,PATH=$G(PATH) 144 I %ZOS="VMS" D Q PATH 145 . S P1=PATH_$S(PATH[":":"*.*",1:":*.*") 146 . S P2=$ZSEARCH(P1) 147 . S:$L(P2) PATH=$S(P2["]":$P(P2,"]",1)_"]",1:$P(P2,":",1)_":") 148 . Q 149 I %ZOS="NT" D Q PATH 150 . S P1=PATH_$S($E(PATH,$L(PATH))'="\":"\*",1:"*"),P2=$ZSEARCH(P1) 151 . S:$L(P2) PATH=$P(P2,"\",1,$L(P2,"\")-1)_"\" 152 . Q 153 I %ZOS="UNIX" D Q PATH 154 . S P1=PATH_$S($E(PATH,$L(PATH))'="/":"/*",1:"*"),P2=$ZSEARCH(P1) 155 . S:$L(P2) PATH=$P(P2,"/",1,$L(P2,"/")-1)_"/" 156 . Q 157 Q PATH 158 ; 159 DEFDIR(DF) ;ef. Default Dir and frmt 160 ;Need to handle NT, VMS and Linux 161 N %ZOS,P1,P2 S %ZOS=$$OS^%ZOSV,DF=$G(DF) 162 Q:DF="." "" ;Special way to get current dir. 163 S:DF="" DF=$G(^XTV(8989.3,1,"DEV")),DF=$P(DF,"^",$S($$PRI^%ZOSV<2:1,1:2)) 164 Q:DF="" "" 165 ;Check syntax, VMS needs disk:[dir] or logical: 166 I %ZOS="VMS" D 167 . I DF[":" S P1=$P(DF,":")_":",P2=$P(DF,":",2) 168 . E S P1="",P2=DF 169 . I P1="",P2["$" S P1=P2,P2="" ;Could be a logical 170 . I $L(P2) S:P2'["[" P2="["_P2 S:P2'["]" P2=P2_"]" 171 . S DF=P1_P2 S:DF'[":" DF=DF_":" 172 . Q 173 ;Check syntax, Unix needs /mnt/fl, ./fl, ~/fl $HOME/fl 174 I %ZOS="UNIX" D 175 . S DF=$TR(DF,"\","/") 176 . S:$E(DF,$L(DF))'="/" DF=DF_"/" 177 . Q 178 ;Check syntax, NT needs c:\dir\ 179 I %ZOS="NT" D 180 . N P1,P2 181 . I DF[":" S P1=$P(DF,":")_":",P2=$P(DF,":",2) 182 . E S P1="",P2=DF 183 . S P2=$TR(P2,"/","\") 184 . I $L(P2) S:".\"'[$E(P2,1) P2="\"_P2 S:$E(P2,$L(P2))'="\" P2=P2_"\" 185 . S DF=P1_P2 186 . Q 187 S DF=$$TRNLNM(DF) ;Resolve logicals 188 Q DF 189 ; 190 FL(X) ;Fl len 191 N ZOSHP1,ZOSHP2 192 S ZOSHP1=$P(X,"."),ZOSHP2=$P(X,".",2) 193 I $L(ZOSHP1)>8 S X=4 Q 194 I $L(ZOSHP2)>3 S X=4 Q 195 Q 196 ; 197 STATUS() ;ef,SR. Return EOF status 198 U $I 199 Q $$EOF($ZEOF) 200 ; 201 EOF(X) ;Eof flag, pass in $ZEOF 202 Q (X=-1) 203 ; 204 MAKEREF(HF,IX,OVF) ;Internal call to rebuild global ref. 205 ;Return %ZISHF,%ZISHO,%ZISHI,%ZISUB 206 N I,F,MX 207 S OVF=$G(OVF,"%ZISHOF") 208 S %ZISHI=$QS(HF,IX),MX=$QL(HF) ; 209 S F=$NA(@HF,IX-1) ;Get first part 210 I IX=1 S %ZISHF=F_"(%ZISHI" ;Build root, IX=1 211 I IX>1 S %ZISHF=$E(F,1,$L(F)-1)_",%ZISHI" ;Build root 212 S %ZISHO=%ZISHF_","_OVF_",%OVFCNT)" ;Make overflow 213 F I=IX+1:1:MX S %ZISHF=%ZISHF_",%ZISUB("_I_")",%ZISUB(I)=$QS(HF,I) 214 S %ZISHF=%ZISHF_")" 215 Q 216 ; 217 READNXT(REC) ;Read any sized record into array. %ZB has terminator 218 N %,I,X,$ES,$ET S REC="",$ET="D READNX^%ZISH Q" 219 U IO R X:5 S %ZB=$A($ZB),REC=$E(X,1,255) 220 Q:$L(X)<256 221 S %=256 F I=1:1 Q:$L(X)<% S REC(I)=$E(X,%,%+254),%=%+255 222 Q 223 READNX ;Check for EOF 224 I $ZE["ENDOFFILE" S %ZA=-1 225 S $EC="" 226 Q 227 ; 228 FTG(%ZX1,%ZX2,%ZX3,%ZX4,%ZX5) ;ef,SR. Unload contents of host file into global 229 ;p1=hostf file directory 230 ;p2=host file name 231 ;p3= $NAME REFERENCE INCLUDING STARTING SUBSCRIPT 232 ;p4=INCREMENT SUBSCRIPT 233 ;p5=Overflow subscript, defaults to "OVF" 234 N %ZA,%ZB,%ZC,X,%OVFCNT,%ZISHF,%ZISHO,POP,%ZISUB,$ES,$ET 235 N I,%ZISH,%ZISH1,%ZISHI,%ZISHL,%ZISHOF,%ZISHOX,%ZISHS,%ZX,%ZISHY 236 S %ZX1=$$DEFDIR($G(%ZX1)),%ZISHOF=$G(%ZX5,"OVF") 237 D MAKEREF(%ZX3,%ZX4,"%ZISHOF") 238 D OPEN^%ZISH(,%ZX1,%ZX2,"R") 239 I POP Q 0 240 S %ZC=1,%ZA=0,$ET="S %ZC=0,%ZA=-1,$EC="""" Q" 241 U IO F K %XX D READNXT(.%XX) Q:$$EOF($ZEOF)!%ZA D 242 . S @%ZISHF=%XX 243 . I $D(%XX)>2 F %OVFCNT=1:1 Q:'$D(%XX(%OVFCNT)) S @%ZISHO=%XX(%OVFCNT) 244 . S %ZISHI=%ZISHI+1 245 . Q 246 D CLOSE() ;Normal exit 247 Q %ZC 248 ; 249 GTF(%ZX1,%ZX2,%ZX3,%ZX4) ;ef,SR. Load contents of global to host file. 250 ;p1=$NAME of global reference 251 ;p2=incrementing subscript 252 ;p3=host file directory 253 ;p4=host file name 254 N %ZISHY,%ZISHOX 255 S %ZISHY=$$MGTF(%ZX1,%ZX2,%ZX3,%ZX4,"W") 256 Q %ZISHY 257 ; 258 GATF(%ZX1,%ZX2,%ZX3,%ZX4) ;ef,SR. Append to host file. 259 ; 260 ;p1=$NAME of global reference 261 ;p2=incrementing subscript 262 ;p3=host file directory 263 ;p4=host file name 264 N %ZISHY 265 S %ZISHY=$$MGTF(%ZX1,%ZX2,%ZX3,%ZX4,"A") 266 Q %ZISHY 267 ; 268 MGTF(%ZX1,%ZX2,%ZX3,%ZX4,%ZX5) ; 269 ;p1=$NAME of global reference 270 ;p2=incrementing subscript 271 ;p3=host file directory 272 ;p4=host file name 273 N %ZISH,%ZISH1,%ZISHI,%ZISHL,%ZISHS,%ZISHOX,IO,%ZX,Y,%ZC 274 D MAKEREF(%ZX1,%ZX2) 275 D OPEN^%ZISH(,$G(%ZX3),%ZX4,%ZX5) ;Default dir set in open 276 I POP Q 0 277 N $ETRAP S $ETRAP="S $EC="""" D CLOSE^%ZISH() Q 0" 278 F Q:'($D(@%ZISHF)#2) S %ZX=@%ZISHF,%ZISHI=%ZISHI+1 U IO W %ZX,! 279 D CLOSE() 280 Q 1 281 ; 1 %ZISH ;IHS\PR,SFISC/AC - Host File Control for OpenM/Cache for NT/VMS ;12/13/2005 2 ;;8.0;KERNEL;**34,65,84,104,191,306,385**;JUL 10, 1995;Build 3 3 ; 4 ; **MODIFIED VERSION FOR CACHE/VMS -- 9/7/01** 5 ; 6 OPEN(X1,X2,X3,X4,X5,X6) ;SR. Open Host File 7 ;X1=handle name 8 ;X2=directory name \dir\ 9 ;X3=file name 10 ;X4=file access mode e.g.: W for write, R for read, A for append. 11 ;X5=Max record size for a new file, X6=Subtype 12 N %,%1,%2,%I,%ZOS,%T,%ZA,%ZISHIO,$ET 13 S $ET="D OPNERR^%ZISH" 14 S U="^",%I=$I,%T=0,POP=0,X2=$$DEFDIR($G(X2)),%ZOS=$$OS^%ZOSV M %ZISHIO=IO 15 I %ZOS'="VMS" S %1=$S(X4["A":"AW",X4["W":"WN",1:"R")_$S(X4["B":"U",1:"S") ;NT & Unix 16 I %ZOS="VMS" S %1=$S(X4["A":"AW",X4["W":"WN",1:"RH")_$S(X4["B":"U",1:"S") 17 ;The next line eliminates the <ENDOFFILE> error for sequential files for the current process. 18 S %ZA=$ZUTIL(68,40,1) ;Work like DSM 19 S %=X2_X3 O %:(%1):2 I '$T S POP=1 Q 20 ;U % S %ZA=$ZA ;Comment out, $ZA is for READ status 21 ;I %ZA=-1 U:%I]"" %I C % S POP=1 Q 22 S IO=%,IO(1,IO)="",IOT="HFS",IOM=80,IOSL=60,POP=0 D SUBTYPE^%ZIS3($G(X6,"P-OTHER")) 23 I $G(X1)]"" D SAVDEV^%ZISUTL(X1) 24 U $S(%I]"":%I,1:$P) 25 Q 26 ; 27 OPNERR ;Handle open error 28 S POP=1,$ECODE="" 29 U:$P]"" $P 30 Q 31 ; 32 CLOSE(X) ;SR. Close HFS device not opened by %ZIS. 33 ;X=HANDLE NAME 34 ;IO=Device 35 N % 36 I $G(IO)]"" C IO K IO(1,IO) 37 I $G(X)]"" D RMDEV^%ZISUTL(X) 38 ;Only reset home if one setup. 39 I $D(IO("HOME"))!$D(^XUTL("XQ",$J,"IOS")) D HOME^%ZIS 40 Q 41 ; 42 OPENERR ; 43 Q 0 44 ; 45 DEL(%ZX1,%ZX2) ;ef,SR. Del fl(s) 46 ;S Y=$$DEL^%ZISH("dir path",$NA(array)) 47 N %,%ZX,%ZXDEL,%ZISH,%ZOS 48 S %ZX1=$$DEFDIR($G(%ZX1)),%ZOS=$$OS^%ZOSV,%ZXDEL=1,%ZISH="" 49 F S %ZISH=$O(@%ZX2@(%ZISH)) Q:%ZISH="" D 50 . N $ETRAP,$ESTACK S $ETRAP="D DELERR^%ZISH" 51 . I %ZISH["*" S %ZXDEL=0 Q ; Wild card not allowed. 52 . S %ZX=$S(%ZISH[%ZX1:%ZISH,1:%ZX1_%ZISH) 53 . I %ZOS="VMS",%ZX'[";" S %ZX=%ZX_";*" 54 . Q:$ZSEARCH(%ZX)']"" ; File doesn't exist 55 . S %=$ZF(-1,$S(%ZOS="UNIX":"rm ",1:"del ")_%ZX) 56 . I $ZSEARCH(%ZX)]"" S %ZXDEL=0 ; Delete was not successful. 57 Q %ZXDEL 58 ; 59 DELERR ;Trap any $ETRAP error, unwind and return. 60 S $ETRAP="D UNWIND^%ZTER" 61 S %ZXDEL=0 62 D UNWIND^%ZTER 63 Q 64 ; 65 LIST(%ZX1,%ZX2,%ZX3) ;ef,SR. Create a local array holding file names 66 ;S Y=$$LIST^ZOSHDOS("\dir\",$NA(array),$NA(return array)) Return 1 if found anything 67 ; 68 N %ZISH,%ZISHN,%ZX,%ZISHY,%ZY,%ZOS 69 S %ZX1=$$DEFDIR($G(%ZX1)),%ZOS=$$OS^%ZOSV 70 ;S %ZX1=$$TRNLNM(%ZX1) 71 ;Get fls to act on 72 S %ZISH="" F S %ZISH=$O(@%ZX2@(%ZISH)) Q:%ZISH="" D 73 . S %ZISHY=$P(%ZISH,"*") 74 . I %ZOS="VMS",%ZISH'["." S %ZISH=%ZISH_".*" ;Allways upper 75 . ;NT, display case, ignore for lookup 76 . S %ZX=%ZX1_%ZISH 77 . F %ZISHN=0:1 D Q:(%ZX="") 78 . . S %ZX=$ZSEARCH($S(%ZISHN:"",1:%ZX)) 79 . . ;Q:(%ZX="")!($$UP^XLFSTR(%ZX)'[%ZISHY)!(%ZX?.E1.2".") 80 . . Q:(%ZX="")!(%ZX?.E1.2".") 81 . . I %ZOS="VMS" S %ZX=$P(%ZX,"]",2),@%ZX3@(%ZX)="" 82 . . I %ZOS="NT" S %ZY=$P(%ZX,"\",$L(%ZX,"\")),@%ZX3@(%ZY)="" 83 . . I %ZOS="UNIX" S %ZY=$P(%ZX,"/",$L(%ZX,"/")) Q:%ZX'[%ZISHY S @%ZX3@(%ZY)="" 84 . . Q 85 Q $O(@%ZX3@(""))]"" 86 ; 87 MV(X1,X2,Y1,Y2) ;ef,SR. Rename a fl 88 ;S Y=$$MV^ZOSHDOS("\dir\","fl","\dir\","fl") 89 ;Unix use mv, NT/VMS use COPY and DEL 90 N %,X,Y,%ZOS,%ZISHX S %ZOS=$$OS^%ZOSV 91 S X1=$$DEFDIR($G(X1)),Y1=$$DEFDIR($G(Y1)) 92 S X=$ZSEARCH(X1_X2),Y=Y1_Y2 ;move X to Y 93 I X="" Q 0 94 S %=$ZF(-1,$S(%ZOS="UNIX":"mv ",1:"copy ")_X_" "_Y) ;Use NT/VMS copy 95 I %ZOS'="UNIX" D 96 . S X2=$P(X,X1,2),%ZISHX(X2)="" 97 . S Y=$$DEL^%ZISH(X1,$NA(%ZISHX)) 98 Q 1 99 ; 100 PWD() ;ef,SR. Print working directory 101 N Y,%ZOS 102 S Y=$$DEFDIR(""),%ZOS=$$OS^%ZOSV 103 I Y="" S Y=$ZSEARCH("*") 104 Q $S(%ZOS["VMS":Y,1:$P(Y,".",1)) 105 ; 106 TRNLNM(PATH) ;ef. Expand logical path 107 N %ZOS,P1,P2 108 S %ZOS=$$OS^%ZOSV,PATH=$G(PATH) 109 I %ZOS="VMS" D Q PATH 110 . S P1=PATH_$S(PATH[":":"*.*",1:":*.*") 111 . S P2=$ZSEARCH(P1) 112 . S:$L(P2) PATH=$S(P2["]":$P(P2,"]",1)_"]",1:$P(P2,":",1)_":") 113 . Q 114 I %ZOS="NT" D Q PATH 115 . S P1=PATH_$S($E(PATH,$L(PATH))'="\":"\*",1:"*"),P2=$ZSEARCH(P1) 116 . S:$L(P2) PATH=$P(P2,"\",1,$L(P2,"\")-1)_"\" 117 . Q 118 I %ZOS="UNIX" D Q PATH 119 . S P1=PATH_$S($E(PATH,$L(PATH))'="/":"/*",1:"*"),P2=$ZSEARCH(P1) 120 . S:$L(P2) PATH=$P(P2,"/",1,$L(P2,"/")-1)_"/" 121 . Q 122 Q PATH 123 ; 124 DEFDIR(DF) ;ef. Default Dir and frmt 125 ;Need to handle NT, VMS and Linux 126 N %ZOS,P1,P2 S %ZOS=$$OS^%ZOSV,DF=$G(DF) 127 Q:DF="." "" ;Special way to get current dir. 128 S:DF="" DF=$G(^XTV(8989.3,1,"DEV")) 129 Q:DF="" "" 130 ;Check syntax, VMS needs disk:[dir] or logical: 131 I %ZOS="VMS" D 132 . I DF[":" S P1=$P(DF,":")_":",P2=$P(DF,":",2) 133 . E S P1="",P2=DF 134 . I P1="",P2["$" S P1=P2,P2="" ;Could be a logical 135 . I $L(P2) S:P2'["[" P2="["_P2 S:P2'["]" P2=P2_"]" 136 . S DF=P1_P2 S:DF'[":" DF=DF_":" 137 . Q 138 ;Check syntax, Unix needs /mnt/fl, ./fl 139 I %ZOS="UNIX" D 140 . S DF=$TR(DF,"\","/") 141 . S:$E(DF,$L(DF))'="/" DF=DF_"/" 142 . Q 143 ;Check syntax, NT needs c:\dir\ 144 I %ZOS="NT" D 145 . N P1,P2 146 . I DF[":" S P1=$P(DF,":")_":",P2=$P(DF,":",2) 147 . E S P1="",P2=DF 148 . S P2=$TR(P2,"/","\") 149 . I $L(P2) S:".\"'[$E(P2,1) P2="\"_P2 S:$E(P2,$L(P2))'="\" P2=P2_"\" 150 . S DF=P1_P2 151 . Q 152 S DF=$$TRNLNM(DF) ;Resolve logicals 153 Q DF 154 ; 155 FL(X) ;Fl len 156 N ZOSHP1,ZOSHP2 157 S ZOSHP1=$P(X,"."),ZOSHP2=$P(X,".",2) 158 I $L(ZOSHP1)>8 S X=4 Q 159 I $L(ZOSHP2)>3 S X=4 Q 160 Q 161 ; 162 STATUS() ;ef,SR. Return EOF status 163 U $I 164 Q $$EOF($ZEOF) 165 ; 166 EOF(X) ;Eof flag, pass in $ZEOF 167 Q (X=-1) 168 ; 169 MAKEREF(HF,IX,OVF) ;Internal call to rebuild global ref. 170 ;Return %ZISHF,%ZISHO,%ZISHI,%ZISUB 171 N I,F,MX 172 S OVF=$G(OVF,"%ZISHOF") 173 S %ZISHI=$QS(HF,IX),MX=$QL(HF) ; 174 S F=$NA(@HF,IX-1) ;Get first part 175 I IX=1 S %ZISHF=F_"(%ZISHI" ;Build root, IX=1 176 I IX>1 S %ZISHF=$E(F,1,$L(F)-1)_",%ZISHI" ;Build root 177 S %ZISHO=%ZISHF_","_OVF_",%OVFCNT)" ;Make overflow 178 F I=IX+1:1:MX S %ZISHF=%ZISHF_",%ZISUB("_I_")",%ZISUB(I)=$QS(HF,I) 179 S %ZISHF=%ZISHF_")" 180 Q 181 ; 182 READNXT(REC) ;Read any sized record into array. %ZB has terminator 183 N %,I,X,$ES,$ET S REC="",$ET="D READNX^%ZISH Q" 184 U IO R X:5 S %ZB=$A($ZB),REC=$E(X,1,255) 185 Q:$L(X)<256 186 S %=256 F I=1:1 Q:$L(X)<% S REC(I)=$E(X,%,%+254),%=%+255 187 Q 188 READNX ;Check for EOF 189 I $ZE["ENDOFFILE" S %ZA=-1 190 S $EC="" 191 Q 192 ; 193 FTG(%ZX1,%ZX2,%ZX3,%ZX4,%ZX5) ;ef,SR. Unload contents of host file into global 194 ;p1=hostf file directory 195 ;p2=host file name 196 ;p3= $NAME REFERENCE INCLUDING STARTING SUBSCRIPT 197 ;p4=INCREMENT SUBSCRIPT 198 ;p5=Overflow subscript, defaults to "OVF" 199 N %ZA,%ZB,%ZC,X,%OVFCNT,%ZISHF,%ZISHO,POP,%ZISUB,$ES,$ET 200 N I,%ZISH,%ZISH1,%ZISHI,%ZISHL,%ZISHOF,%ZISHOX,%ZISHS,%ZX,%ZISHY 201 S %ZX1=$$DEFDIR($G(%ZX1)),%ZISHOF=$G(%ZX5,"OVF") 202 D MAKEREF(%ZX3,%ZX4,"%ZISHOF") 203 D OPEN^%ZISH(,%ZX1,%ZX2,"R") 204 I POP Q 0 205 S %ZC=1,%ZA=0,$ET="S %ZC=0,%ZA=-1,$EC="""" Q" 206 U IO F K %XX D READNXT(.%XX) Q:$$EOF($ZEOF)!%ZA D 207 . S @%ZISHF=%XX 208 . I $D(%XX)>2 F %OVFCNT=1:1 Q:'$D(%XX(%OVFCNT)) S @%ZISHO=%XX(%OVFCNT) 209 . S %ZISHI=%ZISHI+1 210 . Q 211 D CLOSE() ;Normal exit 212 Q %ZC 213 ; 214 GTF(%ZX1,%ZX2,%ZX3,%ZX4) ;ef,SR. Load contents of global to host file. 215 ;p1=$NAME of global reference 216 ;p2=incrementing subscript 217 ;p3=host file directory 218 ;p4=host file name 219 N %ZISHY,%ZISHOX 220 S %ZISHY=$$MGTF(%ZX1,%ZX2,%ZX3,%ZX4,"W") 221 Q %ZISHY 222 ; 223 GATF(%ZX1,%ZX2,%ZX3,%ZX4) ;ef,SR. Append to host file. 224 ; 225 ;p1=$NAME of global reference 226 ;p2=incrementing subscript 227 ;p3=host file directory 228 ;p4=host file name 229 N %ZISHY 230 S %ZISHY=$$MGTF(%ZX1,%ZX2,%ZX3,%ZX4,"A") 231 Q %ZISHY 232 ; 233 MGTF(%ZX1,%ZX2,%ZX3,%ZX4,%ZX5) ; 234 ;p1=$NAME of global reference 235 ;p2=incrementing subscript 236 ;p3=host file directory 237 ;p4=host file name 238 N %ZISH,%ZISH1,%ZISHI,%ZISHL,%ZISHS,%ZISHOX,IO,%ZX,Y,%ZC 239 D MAKEREF(%ZX1,%ZX2) 240 D OPEN^%ZISH(,$G(%ZX3),%ZX4,%ZX5) ;Default dir set in open 241 I POP Q 0 242 N $ETRAP S $ETRAP="S $EC="""" D CLOSE^%ZISH() Q 0" 243 F Q:'($D(@%ZISHF)#2) S %ZX=@%ZISHF,%ZISHI=%ZISHI+1 U IO W %ZX,! 244 D CLOSE() 245 Q 1 246 ; -
WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZISS1.m
r613 r623 1 %ZISS1 ;AC/SFISC - Collect screen parameters 5/29/88 2:02 PM ;1/24/08 16:10 2 ;;8.0;KERNEL;**69,440**;JUL 10, 1995;Build 13 3 ;Per VHA Directive 2004-038, this routine should not be modified 4 VALID ; 5 N %ZISI,%ZISNP,ZISCH,ZISEND,ZISNUM,ZISQ,ZISXL,ZISXLN ;p440 6 D L 7 Q 8 ; 9 SET2 ; 10 S %ZISFN="" F %ZISZ=0:0 S %ZISFN=$O(%ZISZ(%ZISFN)) Q:%ZISFN="" I $D(%ZISZ(%ZISFN))#2 S %ZISXX=%ZISZ(%ZISFN) D INDCK 11 Q 12 INDCK ; 13 S %ZISY="" 14 I "IOEFLD^IOSTBM"[%ZISFN S @%ZISFN=%ZISXX Q 15 I %ZISXX]"" S @("%ZISY="_%ZISXX) 16 ;E S @("%ZISY="_"""""") 17 I $E(%ZISFN,1,2)="IO" S @%ZISFN=%ZISY 18 E S @("IO"_$E(%ZISFN,1,6))=%ZISY 19 Q:'$D(%ZIS)#2 Q:%ZIS'["I" Q:'$D(%ZISZ(%ZISFN,1)) 20 ; 21 SRAY ; 22 S %=%ZISY,%ZISY=$A($E(%ZISY,1)) 23 F %1=2:1:$L(%) S %ZISY=%ZISY_$S($A(%,%1)<32:$A(%,%1),$A(%,%1)=127:127,1:$E(%,%1)) 24 S IOIS(%ZISY)=%ZISFN 25 Q 26 CHECK ;Entry point called from input transforms of fields in DEV/TT files. 27 N %ZISXX,%ZISYY,%ZISI,%ZISNP,%ZISX1,%ZISX2,ZISCH,ZISNUM,ZISQ,ZISXL,ZISXLN ;p440 28 S %ZISXX=X D L S X=%ZISYY 29 Q 30 CHECK1 ;Entry point called from input transforms of fields in DEV/TT files. 31 N %ZISXX,%ZISYY,%ZISI,%ZISNP,%ZISX1,%ZISX2,ZISCH,ZISNUM,ZISQ,ZISXL,ZISXLN ;p440 32 S %ZISXX=$S(X?1"W ".E:$E(X,3,$L(X)),1:X) 33 D L S X=$S(X?1"W ".E:"W "_%ZISYY,1:%ZISYY) 34 Q 35 FORM ;Entry point called from input transforms of fields in DEV/TT files. 36 Q:$L(X,"_")'>1 37 N %ZISSI,%ZISSY ;p440 38 ;F %ZISSI=1:1:$L(X,"_") S %ZISX1=$P(X,"_",%ZISSI) I %ZISX1]"","#?!"[$E(%ZISX1) S X=$S(%ZISSI=1:"",1:$P(X,"_",1,%ZISSI-1)_",")_%ZISX1_$S(%ZISSI<$L(X,"_"):","_$P(X,"_",%ZISSI+1,255),1:"") W !,%ZISSI_"==>"_X 39 S %ZISSY="" 40 F %ZISSI=1:1:$L(X,"_") S %ZISSY=%ZISSY_$P(X,"_",%ZISSI)_$S($P(X,"_",%ZISSI+1)="":"","#?!"[$E($P(X,"_",%ZISSI+1)):",","#?!"[$E($P(X,"_",%ZISSI)):",",1:"_") 41 S X=%ZISSY 42 Q 43 ; 44 L S ZISQ="""",%ZISNP=0,ZISXLN=$L(%ZISXX) I 'ZISXLN S %ZISYY="" Q 45 S ZISXL=0,%ZISYY="" F %ZISI=0:0 S ZISXL=ZISXL+1 S ZISCH=$E(%ZISXX,ZISXL) D L1 Q:ZISXL'<ZISXLN 46 ;I $L(%ZISYY,"$C(")>2,%ZISYY[")_$C(" S %ZISXX=%ZISYY D L2,L3 S %ZISYY=%ZISXX Q 47 S %ZISXX=%ZISYY D L2,L3 S %ZISYY=%ZISXX 48 Q 49 L1 I ZISCH="_"!(ZISCH=",") S %ZISYY=%ZISYY_"_" Q 50 I ZISCH=ZISQ D QUOTE Q 51 I ZISCH="$" D DOLR Q 52 I ZISCH="*" D STAR Q 53 I ZISCH="(" D PAREN Q 54 S %ZISYY=%ZISYY_ZISCH 55 Q 56 L2 ;Find $C(x)_$C(y) and merge 57 N I ;p440 58 F I=1:1:$L(%ZISXX,"_") S %ZISX1=$P(%ZISXX,"_",I),%ZISX2=$P(%ZISXX,"_",I+1) I $E(%ZISX1,1,3)="$C(",$E(%ZISX2,1,3)="$C(" D S2 59 Q 60 L3 ; 61 N I 62 F I=1:1:$L(%ZISXX,"_") I $P(%ZISXX,"_",I)["+","$("'[$E($P(%ZISXX,"_",I)),")"'[$E($P(%ZISXX,"_",I),$L($P(%ZISXX,"_",I))) S $P(%ZISXX,"_",I)="("_$P(%ZISXX,"_",I)_")" 63 Q 64 STAR ;S ZISNUM="" F %ZISI=0:0 S ZISXL=ZISXL+1 S ZISCH=$E(%ZISXX,ZISXL) S:ZISCH?1N ZISNUM=ZISNUM_ZISCH I ZISCH=""!(ZISCH=",") S %ZISYY=%ZISYY_"$C("_+ZISNUM_")",ZISXL=ZISXL-1 Q 65 S ZISNUM="" F %ZISI=0:0 S ZISXL=ZISXL+1 S ZISCH=$E(%ZISXX,ZISXL) S:ZISCH'=""&(ZISCH'=",") ZISNUM=ZISNUM_ZISCH I ZISCH=""!(ZISCH=",") S %ZISYY=%ZISYY_"$C("_ZISNUM_")",ZISXL=ZISXL-1 Q 66 Q 67 QUOTE S %ZISYY=%ZISYY_ZISCH F %ZISI=0:0 S ZISXL=ZISXL+1 S ZISCH=$E(%ZISXX,ZISXL),%ZISYY=%ZISYY_ZISCH I ZISCH=ZISQ!(ZISXL'<ZISXLN) Q 68 Q 69 DOLR ;Looking for $C. 70 I "IXY"[$E(%ZISXX,ZISXL+1) S %ZISYY=%ZISYY_"$"_$E(%ZISXX,ZISXL+1) S ZISXL=ZISXL+1 Q 71 I "ACDEFJLNOPRSTV"[$E(%ZISXX,ZISXL+1)&($E(%ZISXX,ZISXL+2)="(") S %ZISYY=%ZISYY_"$"_$E(%ZISXX,ZISXL+1),ZISXL=ZISXL+2 D PAREN Q 72 S %ZISYY=%ZISYY_"$" ;p440 73 Q 74 PAREN S %ZISYY=%ZISYY_"(",ZISEND=")",%ZISNP=%ZISNP+1 D SCAN S %ZISNP=%ZISNP-1 75 Q 76 SCAN F %ZISI=0:0 S ZISXL=ZISXL+1,ZISCH=$E(%ZISXX,ZISXL) D S1 Q:ZISXL'<ZISXLN!(ZISEND=ZISCH&(%ZISNP)) 77 Q 78 S1 I ZISCH=ZISQ D QUOTE Q 79 I ZISCH="$" D DOLR Q 80 I ZISCH="(" D PAREN Q 81 S %ZISYY=%ZISYY_ZISCH 82 Q 83 ; 84 S2 ;MERGE $C 85 S %ZISX1=$E(%ZISX1,1,$L(%ZISX1)-1),%ZISX2=","_$E(%ZISX2,4,$L(%ZISX2)) 86 S $P(%ZISXX,"_",I,I+1)=%ZISX1_%ZISX2 87 N I D L2 88 Q 1 %ZISS1 ;AC/SFISC - Collect screen parameters 5/29/88 2:02 PM ;11/05/97 08:40 2 ;;8.0;KERNEL;**69**;JUL 10, 1995 3 VALID D L K %ZISI,%ZISNP,ZISCH,ZISEND,ZISNUM,ZISQ,ZISXL,ZISXLN Q 4 ; 5 SET2 S %ZISFN="" F %ZISZ=0:0 S %ZISFN=$O(%ZISZ(%ZISFN)) Q:%ZISFN="" I $D(%ZISZ(%ZISFN))#2 S %ZISXX=%ZISZ(%ZISFN) D INDCK 6 Q 7 INDCK S %ZISY="" 8 I "IOEFLD^IOSTBM"[%ZISFN S @%ZISFN=%ZISXX Q 9 I %ZISXX]"" S @("%ZISY="_%ZISXX) 10 ;E S @("%ZISY="_"""""") 11 I $E(%ZISFN,1,2)="IO" S @%ZISFN=%ZISY 12 E S @("IO"_$E(%ZISFN,1,6))=%ZISY 13 Q:'$D(%ZIS)#2 Q:%ZIS'["I" Q:'$D(%ZISZ(%ZISFN,1)) 14 SRAY S %=%ZISY,%ZISY=$A($E(%ZISY,1)) 15 F %1=2:1:$L(%) S %ZISY=%ZISY_$S($A(%,%1)<32:$A(%,%1),$A(%,%1)=127:127,1:$E(%,%1)) 16 S IOIS(%ZISY)=%ZISFN 17 Q 18 CHECK ;Entry point called from input transforms of fields in DEV/TT files. 19 S %ZISXX=X D L S X=%ZISYY K %ZISXX,%ZISYY,%ZISI,%ZISNP,%ZISX1,%ZISX2,ZISCH,ZISNUM,ZISQ,ZISXL,ZISXLN 20 Q 21 CHECK1 ;Entry point called from input transforms of fields in DEV/TT files. 22 S %ZISXX=$S(X?1"W ".E:$E(X,3,$L(X)),1:X) 23 D L S X=$S(X?1"W ".E:"W "_%ZISYY,1:%ZISYY) K %ZISXX,%ZISYY,%ZISI,%ZISNP,%ZISX1,%ZISX2,ZISCH,ZISNUM,ZISQ,ZISXL,ZISXLN 24 Q 25 FORM ;Entry point called from input transforms of fields in DEV/TT files. 26 Q:$L(X,"_")'>1 27 ;F %ZISSI=1:1:$L(X,"_") S %ZISX1=$P(X,"_",%ZISSI) I %ZISX1]"","#?!"[$E(%ZISX1) S X=$S(%ZISSI=1:"",1:$P(X,"_",1,%ZISSI-1)_",")_%ZISX1_$S(%ZISSI<$L(X,"_"):","_$P(X,"_",%ZISSI+1,255),1:"") W !,%ZISSI_"==>"_X 28 S %ZISSY="" 29 F %ZISSI=1:1:$L(X,"_") S %ZISSY=%ZISSY_$P(X,"_",%ZISSI)_$S($P(X,"_",%ZISSI+1)="":"","#?!"[$E($P(X,"_",%ZISSI+1)):",","#?!"[$E($P(X,"_",%ZISSI)):",",1:"_") 30 S X=%ZISSY K %ZISSI,%ZISSY 31 Q 32 ; 33 L S ZISQ="""",%ZISNP=0,ZISXLN=$L(%ZISXX) I 'ZISXLN S %ZISYY="" Q 34 S (ZISXL)=0,%ZISYY="" F %ZISI=0:0 S ZISXL=ZISXL+1 S ZISCH=$E(%ZISXX,ZISXL) D L1 Q:ZISXL'<ZISXLN 35 ;I $L(%ZISYY,"$C(")>2,%ZISYY[")_$C(" S %ZISXX=%ZISYY D L2,L3 S %ZISYY=%ZISXX Q 36 S %ZISXX=%ZISYY D L2,L3 S %ZISYY=%ZISXX 37 Q 38 L1 I ZISCH="_"!(ZISCH=",") S %ZISYY=%ZISYY_"_" Q 39 I ZISCH=ZISQ D QUOTE Q 40 I ZISCH="$" D DOLR Q 41 I ZISCH="*" D STAR Q 42 I ZISCH="(" D PAREN Q 43 S %ZISYY=%ZISYY_ZISCH Q 44 L2 F I=1:1:$L(%ZISXX,"_") S %ZISX1=$P(%ZISXX,"_",I),%ZISX2=$P(%ZISXX,"_",I+1) I $E(%ZISX1,1,3)="$C(",$E(%ZISX2,1,3)="$C(" D S2 45 Q 46 L3 F I=1:1:$L(%ZISXX,"_") I $P(%ZISXX,"_",I)["+","$("'[$E($P(%ZISXX,"_",I)),")"'[$E($P(%ZISXX,"_",I),$L($P(%ZISXX,"_",I))) S $P(%ZISXX,"_",I)="("_$P(%ZISXX,"_",I)_")" 47 Q 48 STAR ;S ZISNUM="" F %ZISI=0:0 S ZISXL=ZISXL+1 S ZISCH=$E(%ZISXX,ZISXL) S:ZISCH?1N ZISNUM=ZISNUM_ZISCH I ZISCH=""!(ZISCH=",") S %ZISYY=%ZISYY_"$C("_+ZISNUM_")",ZISXL=ZISXL-1 Q 49 S ZISNUM="" F %ZISI=0:0 S ZISXL=ZISXL+1 S ZISCH=$E(%ZISXX,ZISXL) S:ZISCH'=""&(ZISCH'=",") ZISNUM=ZISNUM_ZISCH I ZISCH=""!(ZISCH=",") S %ZISYY=%ZISYY_"$C("_ZISNUM_")",ZISXL=ZISXL-1 Q 50 Q 51 QUOTE S %ZISYY=%ZISYY_ZISCH F %ZISI=0:0 S ZISXL=ZISXL+1 S ZISCH=$E(%ZISXX,ZISXL),%ZISYY=%ZISYY_ZISCH I ZISCH=ZISQ!(ZISXL'<ZISXLN) Q 52 Q 53 DOLR ;LOOKING FOR $C. 54 I "IXY"[$E(%ZISXX,ZISXL+1) S %ZISYY=%ZISYY_"$"_$E(%ZISXX,ZISXL+1) S ZISXL=ZISXL+1 Q 55 I "ACDEFJLNOPRSTV"[$E(%ZISXX,ZISXL+1)&($E(%ZISXX,ZISXL+2)="(") S %ZISYY=%ZISYY_"$"_$E(%ZISXX,ZISXL+1),ZISXL=ZISXL+2 D PAREN 56 Q 57 PAREN S %ZISYY=%ZISYY_"(",ZISEND=")",%ZISNP=%ZISNP+1 D SCAN S %ZISNP=%ZISNP-1 Q 58 SCAN F %ZISI=0:0 S ZISXL=ZISXL+1,ZISCH=$E(%ZISXX,ZISXL) D S1 Q:ZISXL'<ZISXLN!(ZISEND=ZISCH&(%ZISNP)) 59 Q 60 S1 I ZISCH=ZISQ D QUOTE Q 61 I ZISCH="$" D DOLR Q 62 I ZISCH="(" D PAREN Q 63 S %ZISYY=%ZISYY_ZISCH Q 64 ; 65 S2 ;MERGE $C 66 S %ZISX1=$E(%ZISX1,1,$L(%ZISX1)-1),%ZISX2=","_$E(%ZISX2,4,$L(%ZISX2)) 67 S $P(%ZISXX,"_",I,I+1)=%ZISX1_%ZISX2 68 N I D L2 69 Q -
WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZOSFONT.m
r613 r623 1 ZOSFONT ;SFISC/AC - SETS UP ^%ZOSF for Cache for NT/VMS ;10/19/06 14:01 2 ;;8.0;KERNEL;**34,104,365**;JUL 10, 1995;Build 5 3 ;For Cache versions 3.2, 4 and 5 4 S %Y=1 K ^%ZOSF("MASTER"),^%ZOSF("SIGNOFF") 5 N ZO F I="MGR","PROD","VOL" S:$D(^%ZOSF(I)) ZO(I)=^%ZOSF(I) 6 F I=1:2 S Z=$P($T(Z+I),";;",2) Q:Z="" S X=$P($T(Z+1+I),";;",2,99) S ^%ZOSF(Z)=$S($D(ZO(Z)):ZO(Z),1:X) 7 ; 8 MGR W !,"NAME OF MANAGER'S NAMESPACE: "_^%ZOSF("MGR")_"// " R X:$S($G(DTIME):DTIME,1:9999) I X]"" X ^("UCICHECK") G MGR:0[Y S ^%ZOSF("MGR")=X 9 PROD W !,"PRODUCTION (SIGN-ON) NAMESPACE: "_^%ZOSF("PROD")_"// " R X:$S($G(DTIME):DTIME,1:9999) I X]"" X ^("UCICHECK") G PROD:0[Y S ^%ZOSF("PROD")=Y 10 VOL W !,"NAME OF THIS CONFIGURATION: "_^%ZOSF("VOL")_"//" R X:$S($G(DTIME):DTIME,1:9999) I X]"" S:X?1.22U ^%ZOSF("VOL")=X I X'?1.22U W "MUST BE 1-22 uppercase characters." G VOL 11 ; 12 OS S $P(^%ZOSF("OS"),"^",1)="OpenM-NT" S:'$P(^%ZOSF("OS"),"^",2) $P(^%ZOSF("OS"),"^",2)=18 13 ;For Cache 5.1 and above 14 I $$VERSION^ZOSVONT>5 S ^%ZOSF("GSEL")="K ^CacheTempJ($J),^UTILITY($J) D ^%SYS.GSET M ^UTILITY($J)=CacheTempJ($J)" 15 W !!,"ALL SET UP",!! Q 16 Z ;; 17 ;;ACTJ 18 ;;S Y=$$ACTJ^%ZOSV() 19 ;;AVJ 20 ;;S Y=$$AVJ^%ZOSV() 21 ;;BRK 22 ;;U $I:("":"+B") 23 ;;DEL 24 ;;X "ZR ZS @X" 25 ;;EOFF 26 ;;U $I:("":"+S") 27 ;;EON 28 ;;U $I:("":"-S") 29 ;;EOT 30 ;;S Y=$ZA\1024#2 31 ;;ERRTN 32 ;;^%ZTER 33 ;;ETRP 34 ;;Q 35 ;;GD 36 ;;D ^%GD 37 ;;GSEL;Select Globals 38 ;;K ^UTILITY($J) D ^%GSET 39 ;;JOBPARAM 40 ;;D JOBPAR^%ZOSV 41 ;;LABOFF 42 ;;U IO:("":"+S+I-T":$C(13,27)) 43 ;;LOAD 44 ;;N %,%N S %N=0 X "ZL @X F XCNP=XCNP+1:1 S %N=%N+1,%=$T(+%N) Q:$L(%)=0 S @(DIF_XCNP_"",0)"")=%" 45 ;;LPC 46 ;;S Y=$ZC(X) 47 ;;MAXSIZ 48 ;;S $ZS=X+X 49 ;;MGR 50 ;;%SYS 51 ;;MAGTAPE 52 ;;S %MT("BS")="*-1",%MT("FS")="*-2",%MT("WTM")="*-3",%MT("WB")="*-4",%MT("REW")="*-5",%MT("RB")="*-6",%MT("REL")="*-7",%MT("WHL")="*-8",%MT("WEL")="*-9" 53 ;;MTBOT 54 ;;S Y=$ZA\32#2 55 ;;MTONLINE 56 ;;S Y=$ZA\64#2 57 ;;MTWPROT 58 ;;S Y=$ZA\4#2 59 ;;MTERR;;MAGTAPE ERROR 60 ;;S Y=$ZA\32768#2 61 ;;NBRK 62 ;;U $I:("":"-B") 63 ;;NO-PASSALL 64 ;;U $I:("":"-I+T") 65 ;;NO-TYPE-AHEAD 66 ;;U $I:("":"+F":$C(13,27)) 67 ;;PASSALL 68 ;;U $I:("":"+I-T") 69 ;;PRIINQ;; Priority in current queue 70 ;;N %PRIO D ^%PRIO S Y=$S('%PRIO:5,%PRIO>0:8,1:3) 71 ;;PRIORITY;;set priority to X (1=low, 10=high) 72 ;;D @($S(X>7:"NORMAL",X>3:"NORMAL",1:"LOW")_"^%PRIO") ;Don't do HIGH 73 ;;PROGMODE 74 ;;S Y=$ZJOB#2 75 ;;PROD 76 ;;VAH 77 ;;RD 78 ;;D ^%RD 79 ;;RESJOB 80 ;;N OLD S OLD=$ZNSPACE ZNSPACE "%SYS" D ^RESJOB ZNSPACE OLD Q 81 ;;RM 82 ;;I $G(IOT)["TRM" U $I:X 83 ;;RSEL;;ROUTINE SELECT 84 ;;K ^UTILITY($J) D KERNEL^%RSET K %ST ;Special entry point for VA 85 ;;RSUM 86 ;;N %,%1,%3 ZL @X S Y=0 F %=1,3:1 S %1=$T(+%),%3=$F(%1," ") Q:'%3 S %3=$S($E(%1,%3)'=";":$L(%1),$E(%1,%3+1)=";":$L(%1),1:%3-2) F %2=1:1:%3 S Y=$A(%1,%2)*%2+Y 87 ;;RSUM1 88 ;;N %,%1,%3 ZL @X S Y=0 F %=1,3:1 S %1=$T(+%),%3=$F(%1," ") Q:'%3 S %3=$S($E(%1,%3)'=";":$L(%1),$E(%1,%3+1)=";":$L(%1),1:%3-2) F %2=1:1:%3 S Y=$A(%1,%2)*(%2+%)+Y 89 ;;SS 90 ;;D ^%SS 91 ;;SAVE 92 ;;N XCS S XCS="F XCM=1:1 S XCN=$O(@(DIE_XCN_"")"")) Q:+XCN'=XCN S %=^(XCN,0) Q:$E(%,1)=""$"" I $E(%,1)'="";"" ZI %" X "ZR X XCS ZS @X" 93 ;;SIZE 94 ;;S Y=0 F I=1:1 S %=$T(+I) Q:%="" S Y=Y+$L(%)+2 95 ;;TEST 96 ;;I X?1(1"%",1A).7AN,$D(^$ROUTINE(X)) 97 ;;TMK;;MAGTAPE MARK 98 ;;S Y=$ZA\4#2 99 ;;TRAP;;S X="^%ET",@^%ZOSF("TRAP"); User $ETRAP 100 ;;$ZT=X 101 ;;TRMOFF 102 ;;U $I:("":"-I-T":$C(13,27)) 103 ;;TRMON 104 ;;U $I:("":"+I+T") 105 ;;TRMRD;;old Y=$A($ZB),Y=$S(Y<32:Y,Y=127:Y,1:0) 106 ;;S Y=$A($ZB),Y=$S(Y<32:Y,Y=127:Y,1:0) 107 ;;TYPE-AHEAD 108 ;;U $I:("":"-F":$C(13,27)) 109 ;;UCI 110 ;;D UCI^%ZOSV 111 ;;UCICHECK 112 ;;S Y=$$UCICHECK^%ZOSV(X) 113 ;;UPPERCASE 114 ;;S Y=$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") 115 ;;XY 116 ;;S $X=DX,$Y=DY 117 ;;VOL;;VOLUME SET NAME 118 ;;ROU 119 ;;ZD;;$H to external 120 ;;S Y=$ZD(X) 1 ZOSFONT ;SFISC/AC - SETS UP ^%ZOSF FOR Open M for NT ;09/29/98 08:26 2 ;;8.0;KERNEL;**34,104**;JUL 03, 1995 3 S %Y=1 K ^%ZOSF("MASTER"),^%ZOSF("SIGNOFF") 4 K ZO F I="MGR","PROD","VOL" S:$D(^%ZOSF(I)) ZO(I)=^%ZOSF(I) 5 F I=1:2 S Z=$P($T(Z+I),";;",2) Q:Z="" S X=$P($T(Z+1+I),";;",2,99) S ^%ZOSF(Z)=$S($D(ZO(Z)):ZO(Z),1:X) 6 MGR W !,"NAME OF MANAGER'S NAMESPACE: "_^%ZOSF("MGR")_"// " R X:$S($G(DTIME):DTIME,1:9999) I X]"" X ^("UCICHECK") G MGR:Y="" S ^%ZOSF("MGR")=X 7 PROD W !,"PRODUCTION (SIGN-ON) NAMESPACE: "_^%ZOSF("PROD")_"// " R X:$S($G(DTIME):DTIME,1:9999) I X]"" X ^("UCICHECK") G PROD:Y="" S ^%ZOSF("PROD")=Y 8 VOL W !,"NAME OF THIS CONFIGURATION: "_^%ZOSF("VOL")_"//" R X:$S($G(DTIME):DTIME,1:9999) I X]"" S:X?1.5U ^%ZOSF("VOL")=X I X'?1.5U W "MUST BE 1-5 uppercase characters." G VOL 9 OS S $P(^%ZOSF("OS"),"^",1)="OpenM-NT" S:'$P(^%ZOSF("OS"),"^",2) $P(^%ZOSF("OS"),"^",2)=18 10 W !!,"ALL SET UP",!! Q 11 Z ;; 12 ;;ACTJ 13 ;;S Y=$$ACTJ^%ZOSV() 14 ;;AVJ 15 ;;S Y=$$AVJ^%ZOSV() 16 ;;BRK 17 ;;U $I:("":"+B") 18 ;;DEL 19 ;;X "ZR ZS @X" K ^UTILITY("ROU",X) 20 ;;EOFF 21 ;;U $I:("":"+S") 22 ;;EON 23 ;;U $I:("":"-S") 24 ;;EOT 25 ;;S Y=$ZA\1024#2 26 ;;ERRTN 27 ;;^%ZTER 28 ;;ETRP 29 ;;Q 30 ;;GD 31 ;;D ^%GD 32 ;;JOBPARAM 33 ;;D JOBPAR^%ZOSV 34 ;;LABOFF 35 ;;U IO:("":"+S+I-T":$C(13,27)) 36 ;;LOAD 37 ;;S %N=0 X "ZL @X F XCNP=XCNP+1:1 S %N=%N+1,%=$T(+%N) Q:$L(%)=0 S @(DIF_XCNP_"",0)"")=%" 38 ;;LPC 39 ;;S Y=$ZC(X) 40 ;;MAXSIZ 41 ;;S $ZS=X+X 42 ;;MGR 43 ;;%SYS 44 ;;MAGTAPE 45 ;;S %MT("BS")="*-1",%MT("FS")="*-2",%MT("WTM")="*-3",%MT("WB")="*-4",%MT("REW")="*-5",%MT("RB")="*-6",%MT("REL")="*-7",%MT("WHL")="*-8",%MT("WEL")="*-9" 46 ;;MTBOT 47 ;;S Y=$ZA\32#2 48 ;;MTONLINE 49 ;;S Y=$ZA\64#2 50 ;;MTWPROT 51 ;;S Y=$ZA\4#2 52 ;;MTERR;;MAGTAPE ERROR 53 ;;S Y=$ZA\32768#2 54 ;;NBRK 55 ;;U $I:("":"-B") 56 ;;NO-PASSALL 57 ;;U $I:("":"-I+T") 58 ;;NO-TYPE-AHEAD 59 ;;U $I:("":"+F":$C(13,27)) 60 ;;PASSALL 61 ;;U $I:("":"+I-T") 62 ;;PRIINQ;; Priority in current queue 63 ;;N %PRIO D ^%PRIO S Y=$S('%PRIO:5,%PRIO>0:8,1:3) 64 ;;PRIORITY;;set priority to X (1=low, 10=high) 65 ;;D @($S(X>7:"NORMAL",X>3:"NORMAL",1:"LOW")_"^%PRIO") ;Don't do HIGH 66 ;;PROGMODE 67 ;;S Y=$ZJ#2 68 ;;PROD 69 ;;VAH 70 ;;RD 71 ;;D ^%RD 72 ;;RESJOB 73 ;;Q:'$D(DUZ) Q:'$D(^XUSEC("XUMGR",+DUZ)) N XQZ S XQZ="^RESJOB[MGR]" D DO^%XUCI 74 ;;RM 75 ;;U $I:X 76 ;;RSEL;;ROUTINE SELECT 77 ;;K ^UTILITY($J) D KERNEL^%RSET K %ST ;Special entry point for VA 78 ;;RSUM 79 ;;ZL @X S Y=0 F %=1,3:1 S %1=$T(+%),%3=$F(%1," ") Q:'%3 S %3=$S($E(%1,%3)'=";":$L(%1),$E(%1,%3+1)=";":$L(%1),1:%3-2) F %2=1:1:%3 S Y=$A(%1,%2)*%2+Y 80 ;;SS 81 ;;D ^%SS 82 ;;SAVE 83 ;;S XCS="F XCM=1:1 S XCN=$O(@(DIE_XCN_"")"")) Q:+XCN'=XCN S %=^(XCN,0) Q:$E(%,1)=""$"" I $E(%,1)'="";"" ZI %" X "ZR X XCS ZS @X" S ^UTILITY("ROU",X)="" K XCS 84 ;;SIZE 85 ;;S Y=0 F I=1:1 S %=$T(+I) Q:%="" S Y=Y+$L(%)+2 86 ;;TEST 87 ;;I X?1(1"%",1A).7AN,$D(^$ROUTINE(X)) 88 ;;TMK;;MAGTAPE MARK 89 ;;S Y=$ZA\4#2 90 ;;TRAP;;S X="^%ET",@^%ZOSF("TRAP") TO SET ERROR TRAP 91 ;;$ZT=X 92 ;;TRMOFF 93 ;;U $I:("":"-I-T":$C(13,27)) 94 ;;TRMON 95 ;;U $I:("":"+I+T") 96 ;;TRMRD 97 ;;S Y=$A($ZB),Y=$S(Y<32:Y,Y=127:Y,1:0) 98 ;;TYPE-AHEAD 99 ;;U $I:("":"-F":$C(13,27)) 100 ;;UCI 101 ;;D UCI^%ZOSV 102 ;;UCICHECK 103 ;;S Y=$$UCICHECK^%ZOSV(X) 104 ;;UPPERCASE 105 ;;S Y=$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") 106 ;;XY 107 ;;S $X=DX,$Y=DY 108 ;;VOL;;VOLUME SET NAME 109 ;;ROU 110 ;;ZD 111 ;;S Y=$ZD(X) -
WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZOSVONT.m
r613 r623 1 %ZOSV ;SFISC/AC - $View commands for Open M for NT. ;03/03/2008 2 ;;8.0;KERNEL;**34,94,107,118,136,215,293,284,385,425,440**;Jul 10, 1995;Build 13 3 ;Per VHA Directive 2004-038, this routine should not be modified 4 ACTJ() ;# Active jobs 5 N %,V,Y S V=$$VERSION() 6 I V<5 D Q Y 7 . S %=0 F Y=0:1 S %=$ZJOB(%) Q:%="" 8 S Y=$system.License.LUConsumed() ;Cache 5 up 9 Q Y 10 AVJ() ;# available jobs 11 N %,AVJ,V,ZOSV,$ET 12 S V=+$$VERSION() 13 ;Cache 3 and 4 14 ;maxpid: from %SS 15 I V<5 D Q AVJ 16 . N PORT,T,X,MAXPID,LMFLIM 17 . S $ET="",MAXPID=$V($ZU(40,2,118),-2,4) 18 . X "S ZOSV=$ZU(5),%=$ZU(5,""%SYS"") S LMFLIM=$$inquire^LMFCLI,%=$ZU(5,ZOSV)" ;Get the license info 19 . ;Add together the enterprise and division licenses avaliable 20 . S X=$P(LMFLIM,";",2)+$P($P(LMFLIM,"|",2),";",2) 21 . S T=+LMFLIM+$P(LMFLIM,"|",2) ;Check the license total 22 . S AVJ=$S(T<MAXPID:X,1:MAXPID-$$ACTJ) ;Return the smaller of license or pid 23 ;To get available jobs from Cache 5.0 up 24 I V'<5 D Q AVJ 25 . X "S AVJ=$system.License.LUAvailable()" 26 ;Return fixed value not known version 27 Q 15 28 ; 29 PRIINQ() ; 30 Q 8 31 ; 32 UCI ;Current UCI,VOL 33 S Y=$ZU(5)_","_^%ZOSF("VOL") Q 34 ; 35 UCICHECK(X) ;Check if valid namespace (UCI) 36 N Y,% 37 S %=$P(X,",",1),Y=0 I $ZU(90,10,%) S Y=% 38 Q Y 39 ; 40 GETPEER() ;Get the PEER tcp/ip address 41 N PEER,NL,$ET S NL="",PEER="",$ET="S $EC=NL Q NL" 42 I $$OS="VMS" S PEER=$ZF("TRNLNM","VISTA$IP") 43 I '$L(PEER) S PEER=$ZU(111,0) S:$L(PEER) PEER=$A(PEER,1)_"."_$A(PEER,2)_"."_$A(PEER,3)_"."_$A(PEER,4) 44 Q PEER 45 ; 46 SHARELIC(TYPE) ;See if can share a C/S license 47 ;Per Sandy Waal 10/18/2003: With Cache 5.0, your telnet and IP connections are now handled properly. 48 ;N %,%N,%2,UID,%V,$ET S $ET="S $EC="""" Q",%V=$$VERSION() 49 ;I %V'<5 Q 50 ;Type is 1 for C/S and 0 for Telnet 51 ;I %V<3.1 X:TYPE "S %N=$ZU(5),%2=$ZU(5,""%SYS""),%2=$$GetLic^LMFCLI,%N=$ZU(5,%N)" Q 52 ;I %V<5 S:TYPE %=$$GetCSLic^%LICENSE S:'TYPE %=$$ShareLic^%LICENSE 53 ;S $EC="" 54 Q 55 ; 56 JOBPAR ;See if X points to a valid Job. Return its UCI. 57 N NL,$ET S Y="",NL="",$ET="S $EC=NL Q" 58 I $D(^$JOB(X)) S Y=$V(-1,X),Y=$P(Y,"^",14)_","_^%ZOSF("VOL") 59 Q 60 ; 61 NOLOG ;4096 is switch 12 - sign on inhibited. 62 S Y="$V(0,-2,4)\4096#2" Q 63 ; 64 PROGMODE() ;Check if in PROG mode 65 Q $ZJOB#2 66 ; 67 PRGMODE ; 68 N X,XMB,XQZ,XUCI,XUSLNT,XUVOL,Y,ZTPAC 69 W ! S ZTPAC=$S('$D(^VA(200,+DUZ,.1)):"",1:$P(^(.1),U,5)),XUVOL=^%ZOSF("VOL") 70 S X="" X ^%ZOSF("EOFF") R:ZTPAC]"" !,"PAC: ",X:60 D LC^XUS X ^%ZOSF("EON") I X'=ZTPAC W "??"_$C(7) Q 71 S XMB="XUPROGMODE",XMB(1)=DUZ,XMB(2)=$I D ^XMB:$L($T(^XMB)) D BYE^XUSCLEAN K ZTPAC,X,XMB 72 D UCI S XUCI=Y,XQZ="PRGM^ZUA[MGR]",XUSLNT=1 D DO^%XUCI D ^%PMODE U $I:(:"+B+C+R") S $ZT="" Q 73 Q 74 LGR() ;Last Global ref. 75 N $ET,NL S NL="",$ET="S $EC=NL Q NL" 76 Q $ZR 77 ; 78 EC() ;Error code 79 Q $ZE 80 ; 81 DOLRO ;SAVE ENTIRE SYMBOL TABLE IN LOCATION SPECIFIED BY X 82 ;S Y="%" F S Y=$O(@Y) Q:Y="" D 83 ;. I $D(@Y)#2 S @(X_"Y)="_Y) 84 ;. I $D(@Y)>9 S %X=Y_"(",%Y=X_"Y," D %XY^%RCR 85 S Y="%" F M:$D(@Y) @(X_"Y)="_Y) S Y=$O(@Y) Q:Y="" 86 Q 87 ; 88 ORDER ;SAVE PART OF SYMBOL TABLE IN LOCATION SPECIFIED BY X 89 N % 90 S (Y,%)=$P(Y,"*",1) ;I $D(@Y)=0 F S Y=$O(@Y) Q:Y=""!(Y[Y1) 91 Q:Y="" 92 ;S %=$D(@Y) S:%#2 @(X_"Y)="_Y) I %>9 S %X=Y_"(",%Y=X_"Y," D %XY^%RCR 93 ;F S Y=$O(@Y) Q:Y=""!(Y'[Y1) S %=$D(@Y) S:%#2 @(X_"Y)="_Y) I %>9 S %X=Y_"(",%Y=X_"Y," D %XY^%RCR 94 F M:$D(@Y) @(X_"Y)="_Y) S Y=$O(@Y) Q:Y=""!(Y'[%) 95 Q 96 ; 97 PARSIZ ;Old and not used. 98 S X=3 99 Q 100 ; 101 DEVOPN ;List of Devices opened, Not used 102 ;Returns variable Y. Y=Devices owned separated by a comma 103 Q 104 ; 105 DEVOK ; 106 S Y=0,X1=$G(X1) Q:X=2 Q:(X1="HFS")!(X1="SPL")!(X1="MT")!(X1="CHAN") ;Quit w/ OK for HFS, Spool, MT, TCP/IP 107 G:X1="RES" RESOK^%ZIS6 108 N $ET S $ET="D OPNERR Q" 109 O X::$S($D(%ZISTO):%ZISTO,1:0) E S Y=999 Q ;G NOPN 110 S Y=0 I '$D(%ZISCHK)!($G(%ZIS)["T") C X Q 111 S:X]"" IO(1,X)="" Q 112 Q 113 ; 114 OPNERR S $EC="",Y=-1 Q 115 ; 116 GETENV ;Get environment (UCI^VOL^NODE^BOX:VOLUME) 117 N %,%1 S %=$$VERSION,%1=$ZU(86),%1=$S(%<3.1:$P(%1,"*",3),1:$P(%1,"*",2)) 118 D UCI S Y=$P(Y,",")_"^"_^%ZOSF("VOL")_"^"_$ZU(110)_"^"_^%ZOSF("VOL")_":"_%1 119 Q 120 VERSION(X) ;return Cache version, X=1 - return full name 121 Q $S($G(X):$P($ZV,")")_")",1:$P($P($ZV,") ",2),"(")) 122 ; 123 OS() ;Return the OS NT, VMS, Unix 124 Q $S($ZV["VMS":"VMS",$ZV["UNIX":"UNIX",$ZV["Linux":"UNIX",$ZV["Windows":"NT",$ZV["NT":"NT",1:"UNK") 125 ; 126 SETNM(X) ;Set name, Fall into SETENV 127 SETENV ;Set environment 128 N Q,$ET,$ES S $ET="S $EC="""" Q" 129 I $$OS="VMS" S Q=$ZF("SETPRN",$E(X,1,15)) 130 Q 131 ; 132 SID() ;System ID Ver 1 133 N %1,%2,%3,%4,%5,T S T="~" 134 S %1=$ZU(5) ;namespace 135 S %2=$ZU(12,"") ;directory 136 I '$L(%2),$$VERSION'<5.2 S %2=$$defdir^%SYS.GLO(%1) ;remote directory 137 S %3=$G(^XTV(8989.3,1,"SID")),%4=$P(%3,"^",4),%5=$P(%3,"^",5) 138 I $L(%4),$L(%5),%2[%4 S %2=$P(%2,%4)_%5_$P(%2,%4,2,9) 139 S %3=%1_T_%2 ;namespace~directory 140 Q "1~"_%3 141 ; 142 PRI() ;Check if a mixed OS enviroment. 143 ;Default return 1 unless we are on the secondary OS. 144 ;Only Cache on a VMS(1)/Linux or NT(2) mix is supported now. 145 N % S %=1 146 I $P(^XTV(8989.3,1,0),"^",5),$$OS'="VMS" S %=2 147 Q % 148 ; 149 HFSREW(IO,IOPAR) ;Rewind Host File. 150 S $ZT="HFSRWERR" 151 C IO O @(""""_IO_""""_$S(IOPAR]"":":"_IOPAR_":1",1:":1")) I '$T Q 0 152 Q 1 153 HFSRWERR ;Error encountered 154 Q 0 155 LOGRSRC(OPT,TYPE,STATUS) ;record resource usage in ^XTMP("KMPR" 156 Q:'$G(^%ZTSCH("LOGRSRC")) ; quit if RUM not turned on. 157 ; call to RUM routine. 158 D RU^%ZOSVKR($G(OPT),$G(TYPE),$G(STATUS)) 159 Q 160 SETTRM(X) ;Turn on specified terminators. 161 U $I:(:"+T":X) 162 Q 1 163 ; 164 T0 ; start RT clock, obsolete 165 ;S XRT0=$H 166 Q 167 T1 ; store RT datum, obsolete 168 ;S ^%ZRTL(3,XRTL,+$H,XRTN,$P($H,",",2))=XRT0 K XRT0 169 Q 1 %ZOSV ;SFISC/AC - $View commands for Open M for NT. ;4/26/07 09:39 2 ;;8.0;KERNEL;**34,94,107,118,136,215,293,284,385,425**;Jul 10, 1995;Build 18 3 ACTJ() ;# Active jobs 4 N %,V,Y S V=$$VERSION() 5 I V<5 D Q Y 6 . S %=0 F Y=0:1 S %=$ZJOB(%) Q:%="" 7 S Y=$system.License.LUConsumed() ;Cache 5 up 8 Q Y 9 AVJ() ;# available jobs 10 N %,AVJ,V,ZOSV,$ET 11 S V=+$$VERSION() 12 ;Cache 3 and 4 13 ;maxpid: from %SS 14 I V<5 D Q AVJ 15 . N port,t,x,maxpid,lmflim 16 . S $ET="",maxpid=$V($ZU(40,2,118),-2,4) 17 . X "S ZOSV=$ZU(5),%=$ZU(5,""%SYS"") S lmflim=$$inquire^LMFCLI,%=$ZU(5,ZOSV)" ;Get the license info 18 . ;Add together the enterprise and division licenses avaliable 19 . S x=$P(lmflim,";",2)+$P($P(lmflim,"|",2),";",2) 20 . S t=+lmflim+$P(lmflim,"|",2) ;Check the license total 21 . S AVJ=$S(t<maxpid:x,1:maxpid-$$ACTJ) ;Return the smaller of license or pid 22 ;To get available jobs from Cache 5.0 up 23 I V'<5 D Q AVJ 24 . X "S AVJ=$system.License.LUAvailable()" 25 ;Return fixed value not known version 26 Q 15 27 ; 28 PRIINQ() ; 29 Q 8 30 ; 31 UCI ;Current UCI,VOL 32 S Y=$ZU(5)_","_^%ZOSF("VOL") Q 33 ; 34 UCICHECK(X) ;Check if valid namespace (UCI) 35 N Y,% 36 S %=$P(X,",",1),Y=0 I $ZU(90,10,%) S Y=% 37 Q Y 38 ; 39 GETPEER() ;Get the PEER tcp/ip address 40 N PEER,NL,$ET S NL="",$ET="S $EC=NL Q NL",PEER="" 41 I $$OS="VMS" S PEER=$ZF("TRNLNM","VISTA$IP") 42 I '$L(PEER) S PEER=$ZU(111,0) S:$L(PEER) PEER=$A(PEER,1)_"."_$A(PEER,2)_"."_$A(PEER,3)_"."_$A(PEER,4) 43 Q PEER 44 ; 45 SHARELIC(TYPE) ;See if can share a C/S license 46 ;Type is 1 for C/S and 0 for Telnet 47 N %,%N,%2,UID,%V,$ET S $ET="S $EC="""" Q",%V=$$VERSION() 48 I %V<3.1 X:TYPE "S %N=$ZU(5),%2=$ZU(5,""%SYS""),%2=$$GetLic^LMFCLI,%N=$ZU(5,%N)" Q 49 I %V<5 S:TYPE %=$$GetCSLic^%LICENSE S:'TYPE %=$$ShareLic^%LICENSE 50 ;Per Sandy Waal 10/18/2003: With Cache' 5.0, your telnet and IP connections are now handled properly. 51 I %V'<5 S %V=%V 52 S $EC="" 53 Q 54 JOBPAR ;See if X points to a valid Job. Return its UCI. 55 N ZJ S Y="",$ZT="JOBX" 56 Q:'$D(^$JOB(X)) S Y=$V(-1,X),Y=$P(Y,"^",14)_","_^%ZOSF("VOL") 57 JOBX Q 58 ; 59 NOLOG ;4096 is switch 12 - sign on inhibited. 60 S Y="$V(0,-2,4)\4096#2" Q 61 ; 62 PROGMODE() ;Check if in PROG mode 63 Q $ZJ#2 64 ; 65 PRGMODE ; 66 N X,XMB,XQZ,XUCI,XUSLNT,XUVOL,Y,ZTPAC 67 W ! S ZTPAC=$S('$D(^VA(200,+DUZ,.1)):"",1:$P(^(.1),U,5)),XUVOL=^%ZOSF("VOL") 68 S X="" X ^%ZOSF("EOFF") R:ZTPAC]"" !,"PAC: ",X:60 D LC^XUS X ^%ZOSF("EON") I X'=ZTPAC W "??"_$C(7) Q 69 S XMB="XUPROGMODE",XMB(1)=DUZ,XMB(2)=$I D ^XMB:$L($T(^XMB)) D BYE^XUSCLEAN K ZTPAC,X,XMB 70 D UCI S XUCI=Y,XQZ="PRGM^ZUA[MGR]",XUSLNT=1 D DO^%XUCI D ^%PMODE U $I:(:"+B+C+R") S $ZT="" Q 71 Q 72 LGR() S $ZT="LGRX^%ZOSV" 73 Q $ZR ;Last Global ref. 74 LGRX Q "" 75 ; 76 EC() Q $ZE ;Error code 77 ; 78 DOLRO ;SAVE ENTIRE SYMBOL TABLE IN LOCATION SPECIFIED BY X 79 ;S Y="%" F S Y=$O(@Y) Q:Y="" D 80 ;. I $D(@Y)#2 S @(X_"Y)="_Y) 81 ;. I $D(@Y)>9 S %X=Y_"(",%Y=X_"Y," D %XY^%RCR 82 S Y="%" F M:$D(@Y) @(X_"Y)="_Y) S Y=$O(@Y) Q:Y="" 83 Q 84 ; 85 ORDER ;SAVE PART OF SYMBOL TABLE IN LOCATION SPECIFIED BY X 86 N % 87 S (Y,%)=$P(Y,"*",1) ;I $D(@Y)=0 F S Y=$O(@Y) Q:Y=""!(Y[Y1) 88 Q:Y="" 89 ;S %=$D(@Y) S:%#2 @(X_"Y)="_Y) I %>9 S %X=Y_"(",%Y=X_"Y," D %XY^%RCR 90 ;F S Y=$O(@Y) Q:Y=""!(Y'[Y1) S %=$D(@Y) S:%#2 @(X_"Y)="_Y) I %>9 S %X=Y_"(",%Y=X_"Y," D %XY^%RCR 91 F M:$D(@Y) @(X_"Y)="_Y) S Y=$O(@Y) Q:Y=""!(Y'[%) 92 Q 93 ; 94 PARSIZ ; 95 S X=3 96 Q 97 ; 98 DEVOPN ;List of Devices opened 99 ;Returns variable Y. Y=Devices owned separated by a comma 100 Q 101 DEVOK ; 102 S Y=0,X1=$G(X1) Q:X=2 Q:(X1="HFS")!(X1="SPL")!(X1="MT")!(X1="CHAN") ;Quit w/ OK for HFS, Spool, MT, TCP/IP 103 G:X1="RES" RESOK^%ZIS6 104 N $ET S $ET="D OPNERR Q" 105 O X::$S($D(%ZISTO):%ZISTO,1:0) E S Y=999 Q ;G NOPN 106 S Y=0 I '$D(%ZISCHK)!($G(%ZIS)["T") C X Q 107 S:X]"" IO(1,X)="" Q 108 Q 109 ; 110 OPNERR S $EC="",Y=-1 Q 111 ; 112 GETENV ;Get environment (UCI^VOL^NODE^BOX:VOLUME) 113 N %,%1 S %=$$VERSION,%1=$ZU(86),%1=$S(%<3.1:$P(%1,"*",3),1:$P(%1,"*",2)) 114 D UCI S Y=$P(Y,",")_"^"_^%ZOSF("VOL")_"^"_$ZU(110)_"^"_^%ZOSF("VOL")_":"_%1 115 Q 116 VERSION(X) ;return Cache version, X=1 - return full name 117 Q $S($G(X):$P($ZV,")")_")",1:$P($P($ZV,") ",2),"(")) 118 ; 119 OS() ;Return the OS NT, VMS, Unix 120 Q $S($ZV["VMS":"VMS",$ZV["Windows":"NT",$ZV["NT":"NT",$ZV["UNIX":"UNIX",1:"UNK") 121 ; 122 SETNM(X) ;Set name, Fall into SETENV 123 SETENV ;Set environment 124 N Q,$ET,$ES S $ET="S $EC="""" Q" 125 I $$OS="VMS" S Q=$ZF("SETPRN",$E(X,1,15)) 126 Q 127 ; 128 SID() ;System ID Ver 1 129 N %1,%2,%3,T S T="~" 130 S %1=$ZU(5) ;namespace 131 S %2=$ZU(12,"") ;directory 132 I '$L(%2),$$VERSION'<5.2 S %2=$$defdir^%SYS.GLO(%1) ;remote directory 133 S %3=%1_T_%2 ;namespace~directory 134 Q "1~"_%3 135 ; 136 PRI() ;Check if a mixed OS enviroment. 137 ;Default return 1 unless we are on the secondary OS. 138 ;Only Cache on a VMS(1)/Linux(2) mix is supported now. 139 N % S %=1 140 I $P(^XTV(8989.3,1,0),"^",5),$$OS'="VMS" S %=2 141 ;I $P(^XTV(8989.3,1,0),"^",5),$$OS["NT" S %=2 142 Q % 143 ; 144 HFSREW(IO,IOPAR) ;Rewind Host File. 145 S $ZT="HFSRWERR" 146 C IO O @(""""_IO_""""_$S(IOPAR]"":":"_IOPAR_":1",1:":1")) I '$T Q 0 147 Q 1 148 HFSRWERR ;Error encountered 149 Q 0 150 LOGRSRC(OPT,TYPE,STATUS) ;record resource usage in ^XTMP("KMPR" 151 Q:'$G(^%ZTSCH("LOGRSRC")) ; quit if RUM not turned on. 152 ; call to RUM routine. 153 D RU^%ZOSVKR($G(OPT),$G(TYPE),$G(STATUS)) 154 Q 155 SETTRM(X) ;Turn on specified terminators. 156 U $I:(:"+T":X) 157 Q 1 158 ; 159 T0 ; start RT clock 160 ;S XRT0=$H 161 Q 162 T1 ; store RT datum, obsolete 163 ;S ^%ZRTL(3,XRTL,+$H,XRTN,$P($H,",",2))=XRT0 K XRT0 164 Q -
WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZTLOAD4.m
r613 r623 1 %ZTLOAD4 ;SEA/RDS-TaskMan: P I: Is Queued? ;1/24/08 16:15 2 ;;8.0;KERNEL;**440**;JUL 10, 1995;Build 13 3 ;Per VHA Directive 2004-038, this routine should not be modified 4 ;Call with ZTSK, [ZTCPU]; Return ZTSK() 5 INPUT ;check input parameters for error conditions 6 N %,$ES,$ET,%ZTVOL,ZTREC,ZTD,ZT1,ZT2,ZT3 7 I $D(ZTSK)[0 S ZTSK="" 8 I $D(ZTSK)>1 S %=ZTSK K ZTSK S ZTSK=% 9 I ZTSK<1!(ZTSK\1'=ZTSK) S ZTSK="",ZTSK(0)="",ZTSK("E")="IT" G QUIT 10 S ZTSK(0)="",ZTSK("E")="U",$ET="Q:$ES S $EC="""" G QUIT^%ZTLOAD4" 11 S %ZTVOL=^%ZOSF("VOL") 12 I $D(ZTCPU)[0 S ZTCPU=%ZTVOL 13 I ZTCPU="" S ZTCPU=%ZTVOL 14 I ZTCPU'=%ZTVOL G THERE 15 ; 16 HERE ;lookup task's status on current volume set 17 L +^%ZTSK(ZTSK):1 18 I $D(^%ZTSK(ZTSK,0))[0 S ZTSK("E")="I" G QUIT 19 S ZTREC=^%ZTSK(ZTSK,0),ZTD=$G(^(.04)) 20 S ZTSK("DUZ")=$P(ZTREC,U,3),ZTSK("D")=$P(ZTREC,U,6) ;scheduled $H 21 I ZTD]"",$D(^%ZTSCH(ZTD,ZTSK))#2 S ZTSK(0)=1 G QUIT 22 I ZTD]"",$D(^%ZTSCH("JOB",ZTD,ZTSK))#2 S ZTSK(0)=1 G QUIT 23 ; 24 S ZT1="" F S ZT1=$O(^%ZTSCH(ZT1)) Q:'ZT1 I $D(^(ZT1,ZTSK))#2 S ZTSK(0)=1 G QUIT 25 S ZT1="IO",ZT2="" F S ZT2=$O(^%ZTSCH(ZT1,ZT2)),ZT3="" Q:ZT2="" F S ZT3=$O(^%ZTSCH(ZT1,ZT2,ZT3)) Q:ZT3="" I $D(^(ZT3,ZTSK))#2 S ZTSK(0)=1 G QUIT 26 S ZT1="JOB",ZT2="" F S ZT2=$O(^%ZTSCH(ZT1,ZT2)) Q:ZT2="" I $D(^(ZT2,ZTSK))#2 S ZTSK(0)=1 G QUIT 27 S ZT1="LINK",ZT2="" F S ZT2=$O(^%ZTSCH(ZT1,ZT2)),ZT3="" Q:ZT2="" F S ZT3=$O(^%ZTSCH(ZT1,ZT2,ZT3)) Q:ZT3="" I $D(^(ZT3,ZTSK))#2 S ZTSK(0)=1 G QUIT 28 S ZTSK(0)=0 29 ; 30 QUIT ;cleanup and quit 31 L:ZTSK -^%ZTSK(ZTSK) ;K %ZTCPU,%ZTM,%ZTM1,%ZTM2,%ZTMAST,%ZTVOL,X,Y,ZT,ZT1,ZT2,ZT3,ZTCPU,ZTD,ZTREC 32 I ZTSK(0)]"" K ZTSK("E") Q 33 I ZTSK("E")'="U" Q 34 S ZTSK("E",0)=$$EC^%ZOSV 35 Q 36 ; 37 THERE ;rest of code looks up task's status on some other volume set 38 N %ZTCPU,%ZTM,X,Y 39 ; 40 FILES ;find TaskMan files on the volume set to be searched 41 S %ZTCPU=$O(^%ZIS(14.5,"B",ZTCPU,"")) 42 I %ZTCPU="" S ZTSK("E")="IS" G QUIT 43 S %ZTM=$P(^%ZOSF("MGR"),",") 44 S %ZTM=$S($D(^%ZIS(14.5,%ZTCPU,0))[0:%ZTM,$P(^(0),U,6)="":%ZTM,1:$P(^(0),U,6)) 45 S X=%ZTM,Y=ZTCPU 46 S ZTSK("E")="LS",ZT=$D(^[X,Y]%ZTSK(0)),ZTSK("E")="U" ; check link 47 ; 48 SEARCH ;find out if task is queued on that volume set 49 I $D(^[X,Y]%ZTSK(ZTSK,0))[0 S ZTSK("E")="I" G QUIT 50 S ZTREC=^[X,Y]%ZTSK(ZTSK,0),ZTD=$G(^(.04)) 51 S ZTSK("DUZ")=$P(ZTREC,U,3),ZTSK("D")=$P(ZTREC,U,6) 52 I ZTD]"",$D(^[X,Y]%ZTSCH(ZTD,ZTSK))#2 S ZTSK(0)=1 G QUIT 53 I ZTD]"",$D(^[X,Y]%ZTSCH("JOB",ZTD,ZTSK))#2 S ZTSK(0)=1 G QUIT 54 ; 55 S ZT1="" F S ZT1=$O(^[X,Y]%ZTSCH(ZT1)) Q:'ZT1 I $D(^(ZT1,ZTSK))#2 S ZTSK(0)=1 G QUIT 56 S ZT1="IO",ZT2="" F S ZT2=$O(^[X,Y]%ZTSCH(ZT1,ZT2)),ZT3="" Q:ZT2="" F S ZT3=$O(^[X,Y]%ZTSCH(ZT1,ZT2,ZT3)) Q:ZT3="" I $D(^(ZT3,ZTSK))#2 S ZTSK(0)=1 G QUIT 57 S ZT1="JOB",ZT2="" F S ZT2=$O(^[X,Y]%ZTSCH(ZT1,ZT2)) Q:ZT2="" I $D(^(ZT2,ZTSK))#2 S ZTSK(0)=1 G QUIT 58 S ZT1="LINK",ZT2="" F S ZT2=$O(^[X,Y]%ZTSCH(ZT1,ZT2)),ZT3="" Q:ZT2="" F S ZT3=$O(^[X,Y]%ZTSCH(ZT1,ZT2,ZT3)) Q:ZT3="" I $D(^(ZT3,ZTSK))#2 S ZTSK(0)=1 G QUIT 59 S ZTSK(0)=0 G QUIT 60 ; 1 %ZTLOAD4 ;SEA/RDS-TaskMan: P I: Is Queued? ;7/26/91 11:55 ; 2 ;;8.0;KERNEL;;JUL 10, 1995 3 ;;7.0; 4 ; 5 INPUT ;check input parameters for error conditions 6 I $D(ZTSK)[0 S ZTSK="" 7 I $D(ZTSK)>1 S ZTLOAD=ZTSK K ZTSK S ZTSK=ZTLOAD K ZTLOAD 8 I ZTSK<1!(ZTSK\1'=ZTSK) S ZTSK="",ZTSK(0)="",ZTSK("E")="IT" G QUIT 9 S ZTSK(0)="",ZTSK("E")="U",X="QUIT^%ZTLOAD3",@^%ZOSF("TRAP") 10 S %ZTVOL=^%ZOSF("VOL") 11 I $D(ZTCPU)[0 S ZTCPU=%ZTVOL 12 I ZTCPU="" S ZTCPU=%ZTVOL 13 I ZTCPU'=%ZTVOL G THERE 14 ; 15 HERE ;lookup task's status on current volume set 16 L +^%ZTSK(ZTSK) I $D(^%ZTSK(ZTSK,0))[0 S ZTSK("E")="I" G QUIT 17 S ZTREC=^%ZTSK(ZTSK,0),ZTD=$P(ZTREC,U,6) 18 S ZTSK("DUZ")=$P(ZTREC,U,3),ZTSK("D")=ZTD 19 I ZTD]"",$D(^%ZTSCH(ZTD,ZTSK))#2 S ZTSK(0)=1 G QUIT 20 I ZTD]"",$D(^%ZTSCH("JOB",ZTD,ZTSK))#2 S ZTSK(0)=1 G QUIT 21 ; 22 S ZT1="" F ZT=0:0 S ZT1=$O(^%ZTSCH(ZT1)) Q:'ZT1 I $D(^(ZT1,ZTSK))#2 S ZTSK(0)=1 G QUIT 23 S ZT1="IO",ZT2="" F ZT=0:0 S ZT2=$O(^%ZTSCH(ZT1,ZT2)),ZT3="" Q:ZT2="" F ZT=0:0 S ZT3=$O(^%ZTSCH(ZT1,ZT2,ZT3)) Q:ZT3="" I $D(^(ZT3,ZTSK))#2 S ZTSK(0)=1 G QUIT 24 S ZT1="JOB",ZT2="" F ZT=0:0 S ZT2=$O(^%ZTSCH(ZT1,ZT2)) Q:ZT2="" I $D(^(ZT2,ZTSK))#2 S ZTSK(0)=1 G QUIT 25 S ZT1="LINK",ZT2="" F ZT=0:0 S ZT2=$O(^%ZTSCH(ZT1,ZT2)),ZT3="" Q:ZT2="" F ZT=0:0 S ZT3=$O(^%ZTSCH(ZT1,ZT2,ZT3)) Q:ZT3="" I $D(^(ZT3,ZTSK))#2 S ZTSK(0)=1 G QUIT 26 S ZTSK(0)=0 27 ; 28 QUIT ;cleanup and quit 29 L:ZTSK -^%ZTSK(ZTSK) K %ZTCPU,%ZTM,%ZTM1,%ZTM2,%ZTMAST,%ZTVOL,X,Y,ZT,ZT1,ZT2,ZT3,ZTCPU,ZTD,ZTREC 30 I ZTSK(0)]"" K ZTSK("E") Q 31 I ZTSK("E")'="U" Q 32 S ZTSK("E",0)=$$EC^%ZOSV 33 Q 34 ; 35 THERE ;rest of code looks up task's status on some other volume set 36 ; 37 FILES ;find TaskMan files on the volume set to be searched 38 S %ZTCPU=$O(^%ZIS(14.5,"B",ZTCPU,"")) 39 I %ZTCPU="" S ZTSK("E")="IS" G QUIT 40 S %ZTM=$P(^%ZOSF("MGR"),",") 41 S %ZTM=$S($D(^%ZIS(14.5,%ZTCPU,0))[0:%ZTM,$P(^(0),U,6)="":%ZTM,1:$P(^(0),U,6)) 42 S X=%ZTM,Y=ZTCPU 43 S ZTSK("E")="LS",ZT=$D(^[X,Y]%ZTSK(0)),ZTSK("E")="U" ; check link 44 ; 45 SEARCH ;find out if task is queued on that volume set 46 I $D(^[X,Y]%ZTSK(ZTSK,0))[0 S ZTSK("E")="I" G QUIT 47 S ZTREC=^[X,Y]%ZTSK(ZTSK,0),ZTD=$P(ZTREC,U,6) 48 S ZTSK("DUZ")=$P(ZTREC,U,3),ZTSK("D")=ZTD 49 I ZTD]"",$D(^[X,Y]%ZTSCH(ZTD,ZTSK))#2 S ZTSK(0)=1 G QUIT 50 I ZTD]"",$D(^[X,Y]%ZTSCH("JOB",ZTD,ZTSK))#2 S ZTSK(0)=1 G QUIT 51 ; 52 S ZT1="" F ZT=0:0 S ZT1=$O(^[X,Y]%ZTSCH(ZT1)) Q:'ZT1 I $D(^(ZT1,ZTSK))#2 S ZTSK(0)=1 G QUIT 53 S ZT1="IO",ZT2="" F ZT=0:0 S ZT2=$O(^[X,Y]%ZTSCH(ZT1,ZT2)),ZT3="" Q:ZT2="" F ZT=0:0 S ZT3=$O(^[X,Y]%ZTSCH(ZT1,ZT2,ZT3)) Q:ZT3="" I $D(^(ZT3,ZTSK))#2 S ZTSK(0)=1 G QUIT 54 S ZT1="JOB",ZT2="" F ZT=0:0 S ZT2=$O(^[X,Y]%ZTSCH(ZT1,ZT2)) Q:ZT2="" I $D(^(ZT2,ZTSK))#2 S ZTSK(0)=1 G QUIT 55 S ZT1="LINK",ZT2="" F ZT=0:0 S ZT2=$O(^[X,Y]%ZTSCH(ZT1,ZT2)),ZT3="" Q:ZT2="" F ZT=0:0 S ZT3=$O(^[X,Y]%ZTSCH(ZT1,ZT2,ZT3)) Q:ZT3="" I $D(^(ZT3,ZTSK))#2 S ZTSK(0)=1 G QUIT 56 S ZTSK(0)=0 G QUIT 57 ; -
WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZIS.m
r613 r623 1 %ZIS ;SFISC/AC,RWF -- DEVICE HANDLER ;1/24/08 16:06 2 ;;8.0;KERNEL;**18,23,69,112,199,191,275,363,440**;JUL 10, 1995;Build 13 3 ;Per VHA Directive 2004-038, this routine should not be modified 4 N %ZISOS,%ZISV 5 S U="^",%ZISOS=$G(^%ZOSF("OS")),%ZISV=$G(^%ZOSF("VOL")) 6 ;Check SPOOLER special case first 7 INIT I $D(ZTQUEUED),$G(IOT)="SPL",$D(IO)#2,$D(IO(0))#2,IO]"",IO=IO(0),$D(IO(1,IO))#2,%ZISOS["VAX DSM"!(%ZISOS["M/VX"),$G(IOP)[ION!(IOP[IO) K %ZIS,%IS,IOP Q 8 ; 9 I '$D(%ZIS),$D(%IS) M %ZIS=%IS 10 S:'($D(%ZIS)#2) %ZIS="M" M %IS=%ZIS ;update %IS for now 11 I '$D(^XUTL("XQ",$J,"MIXED OS")) S ^XUTL("XQ",$J,"MIXED OS")=$$PRI^%ZOSV 12 S %ZIS("PRI")=$G(^XUTL("XQ",$J,"MIXED OS"),1) 13 ; 14 I $D(ZTQUEUED) D I '$D(IOP) S POP=1 G EXIT^%ZIS1 15 .I $D(ZTIO)#2,ZTIO="" S:%IS'[0 %IS=%IS_"0",%ZIS=%ZIS_"0" 16 I '$D(ZTQUEUED),%IS["T",$P($G(IOP),";")="Q" S POP=1 G EXIT^%ZIS1 17 N %,%A,%E,%H,%I,%X,%XX,%Y,%Z,%Z1,%Z2,%Z9,%Z90,%Z91,%Z95,%ZISB,%ZTIME,%ZTYPE 18 N %ZHFN,%ZISOLD,DTOUT,DUOUT 19 ;Save symbols to restore if don't open a device 20 D SYMBOL^%ZISUTL(0,$NA(%ZISOLD)) 21 A D CLEAN ;(p363) K IO("CLOSE"),IO("HFSIO") 22 K IO("P"),IO("Q"),IO("S"),IO("T") 23 K2 D K2^%ZIS1 24 S %ZISB=%ZIS'["N",(%E,%H,POP)=0,%Y="" S:'$D(IO(0)) IO(0)=$I 25 I %ZISOS["VAX DSM",$I["SYS$INPUT:.;" S:%ZIS'[0 %IS=%IS_"0",%ZIS=%ZIS_"0" 26 ;I %IS["T"&(%IS["0") S (%H,%E)=0 G ^%ZIS1 27 I $D(IOP),IOP=$I!(IOP="HOME")!(0[IOP),$D(^XUTL("XQ",$J,"IO")) D HOME K %IS,%Y,%ZIS,%ZISB,%ZISV,IOP Q 28 ;Don't worry about HOME if %ZIS[0 29 D:%ZIS'[0 GETHOME G EXIT^%ZIS1:POP,^%ZIS1 ;Jump to next part 30 ; 31 GETHOME I $D(IO("HOME")),$P(IO("HOME"),"^",2)=IO(0) S (%E,%H)=+IO("HOME") Q 32 I $D(^XUTL("XQ",$J,"IOS")),$D(^("IO")),IO(0)=^("IO") S (%E,%H)=^("IOS") Q 33 ;CALL LINEPORT CODE HERE--- 34 S %=$$LINEPORT^%ZISUTL I % S (%E,%H)=% Q 35 S %ZISVT=$I D VTLKUP I '%E S %ZISVT=$I D VIRTUAL 36 I %ZISVT=""!(%E'>0) I %IS'[0 O IO(0)::0 I $T U IO(0) W !,"HOME DEVICE ("_$I_") DOES NOT EXIST IN THE DEVICE FILE",!,"PLEASE CONTACT YOUR SYSTEM MANAGER!",*7 37 S %H=%E S:'%H&(%IS'[0) POP=1 S:(%H>0)&('$D(IO("HOME"))) IO("HOME")=%H_"^"_$I 38 Q 39 VIRTUAL ;See if a Virtual Terminal (LAT, TELNET) 40 ;Change the MSM check for telnet to work with v4.4 41 I %ZISOS["MSM" X "I $P($ZV,""Version "",2)'<3 S %ZISVT=$ZDE(+%ZISVT) I %ZISVT?.E1""~""4.5N.E S %ZISVT=""TELNET""" 42 F %ZISI=$L(%ZISVT):-1:0 D:$D(^%ZIS(1,"C",%ZISVT)) Q:$S('%E:0,'$D(^%ZIS(1,%E,"TYPE")):0,^("TYPE")="VTRM":1,1:0) S %ZISVT=$E(%ZISVT,1,%ZISI) 43 .D VTLKUP Q:$S('%E:0,'$D(^%ZIS(1,%E,"TYPE")):0,^("TYPE")="VTRM":1,1:0) 44 .S %X=0 F %ZISX=%ZISV,"" Q:%X>0 S %X=0 F S %E=+$O(^%ZIS(1,"CPU",%ZISX_"."_%ZISVT,%X)) S %X=%E Q:%E'>0 I $G(^%ZIS(1,+%E,"TYPE"))="VTRM" Q 45 Q 46 VTLKUP F %ZISX=%ZISV,"" S %E=+$O(^%ZIS(1,"G","SYS."_%ZISX_"."_%ZISVT,0)) Q:%E S %E=+$O(^%ZIS(1,"CPU",%ZISX_"."_%ZISVT,0)) Q:%E 47 Q 48 ; 49 CURRENT N POP,%ZIS,%IS,%E,%H 50 S FF="#",SL=24,BS="*8",RM=80,(SUB,XY)="",%IS=0,%ZISOS=$G(^%ZOSF("OS")),%ZISV=$G(^("VOL")),POP=0 51 D GETHOME K %E,%IS,%ZISI,%ZISOS,%ZISV,%ZISVT,%ZISX Q:POP 52 I $D(^%ZIS(1,%H,"SUBTYPE")) S SUB=+^("SUBTYPE") K %H 53 I $D(SUB),SUB,$D(^%ZIS(2,SUB,1)) S SUB=$S($D(^(0)):$P(^(0),"^"),1:""),FF=$P(^(1),"^",2),SL=$P(^(1),"^",3),BS=$P(^(1),"^",4),XY=$P(^(1),"^",5),RM=+^(1) 54 E S SUB="" 55 I $D(^%ZOSF("RM")) N X S X=RM X ^("RM") K %A 56 Q 57 HOME ;Entry point to establish IO* variables for home device. 58 D CLEAN ;(p363) 59 N X I '$D(^XUTL("XQ",$J,"IO")) S IOP="HOME" D ^%ZIS Q 60 D RESETVAR 61 I '$D(IO("C")),$G(IOM),IO=$I,$D(IO(1,IO)),$D(^%ZOSF("RM")) S X=+IOM X ^("RM") 62 Q 63 ;IO("Q") is checked by many routines after a call to ^%ZISC, so only clean on call to %ZIS. 64 CLEAN ;Cleanup env. Called from %ZISC also. 65 I $G(IOT)'="SPL" K IO("DOC"),IO("SPOOL") ;(p446) 66 I $G(IOT)'="HFS" K IO("HFSIO") ;p446 67 S (IOPAR,IOUPAR)="" 68 Q 69 ; 70 RESETVAR ;Reset home IO* variables. 71 I '$D(^XUTL("XQ",$J,"IO")) Q 72 N % 73 F %="IO","IOBS","IOF","IOM","ION","IOS","IOSL","IOST","IOST(0)","IOT","IOXY","IOPAR","IOUPAR" I $D(^XUTL("XQ",$J,%))#2 S @%=^(%) 74 F %="IO(""IP"")","IO(""CLNM"")","IO(""DOC"")","IO(""HFSIO"")","IO(""SPOOL"")" I $D(^XUTL("XQ",$J,%))#2 S @%=^(%) 75 S POP=0,IO(0)=IO 76 Q 77 SAVEVAR ;Save home IO* variables, called from XUS1,%ZTMS3 78 N % 79 F %="IO","IOBS","IOF","IOM","ION","IOS","IOSL","IOST","IOST(0)","IOT","IOXY","IOPAR","IOUPAR" I $D(@%) S ^XUTL("XQ",$J,%)=@% 80 F %="IO(""IP"")","IO(""CLNM"")","IO(""DOC"")","IO(""HFSIO"")","IO(""SPOOL"")" I $D(@%) S ^XUTL("XQ",$J,%)=@% 81 Q 82 ZISLPC Q ;No longer called in Kernel v8. 83 ; 84 HLP1 G EN1^%ZIS7 85 HLP2 N %E,%H,%X,%ZISV,X S %ZISV=$S($D(^%ZOSF("VOL")):^("VOL"),1:"") G EN2^%ZIS7 86 ; 87 REWIND(IO2,IOT,IOPAR) ;Rewind Device 88 N %,X,Y,$ES,$ET S $ET="D REWERR^%ZIS Q 0" 89 S %=$I 90 I '($D(IO2)#2)!'$D(IOT)!'$D(IOPAR) Q 0 91 I "MT^SDP^HFS"'[IOT Q 0 92 S @("Y=$$REW"_IOT_"^%ZIS4(IO2,IOPAR)") 93 U % 94 Q Y 95 REWERR ;Error encountered 96 S IO("ERROR")=$EC 97 S $EC="",$ET="Q:$ES>1 S $EC="""" Q 0" S $EC=",U1," 98 Q 0 99 ; 1 %ZIS ;SFISC/AC,RWF -- DEVICE HANDLER ;10/14/2004 08:46 2 ;;8.0;KERNEL;**18,23,69,112,199,191,275,363**;JUL 10, 1995 3 N %ZISOS,%ZISV 4 S U="^",%ZISOS=$G(^%ZOSF("OS")),%ZISV=$G(^%ZOSF("VOL")) 5 ;Check SPOOLER special case first 6 INIT I $D(ZTQUEUED),$G(IOT)="SPL",$D(IO)#2,$D(IO(0))#2,IO]"",IO=IO(0),$D(IO(1,IO))#2,%ZISOS["VAX DSM"!(%ZISOS["M/VX"),$G(IOP)[ION!(IOP[IO) K %ZIS,%IS,IOP Q 7 ; 8 I '$D(%ZIS),$D(%IS) M %ZIS=%IS 9 S:'($D(%ZIS)#2) %ZIS="M" M %IS=%ZIS ;update %IS for now 10 ; 11 I $D(ZTQUEUED) D I '$D(IOP) S POP=1 G EXIT^%ZIS1 12 .I $D(ZTIO)#2,ZTIO="" S:%IS'[0 %IS=%IS_"0",%ZIS=%ZIS_"0" 13 I '$D(ZTQUEUED),%IS["T",$P($G(IOP),";")="Q" S POP=1 G EXIT^%ZIS1 14 N %,%A,%E,%H,%I,%X,%XX,%Y,%Z,%Z1,%Z9,%Z90,%Z91,%Z95,%ZISB,%ZTIME,%ZTYPE 15 N %ZHFN,%ZISOLD,DTOUT,DUOUT 16 ;Save symbols to restore if don't open a device 17 D SYMBOL^%ZISUTL(0,$NA(%ZISOLD)) 18 A D CLEAN ;(p363) K IO("CLOSE"),IO("HFSIO") 19 K IO("P"),IO("Q"),IO("S"),IO("T") 20 K2 D K2^%ZIS1 21 S %ZISB=%ZIS'["N",(%E,%H,POP)=0,%Y="" S:'$D(IO(0)) IO(0)=$I 22 I %ZISOS["VAX DSM",$I["SYS$INPUT:.;" S:%ZIS'[0 %IS=%IS_"0",%ZIS=%ZIS_"0" 23 ;I %IS["T"&(%IS["0") S (%H,%E)=0 G ^%ZIS1 24 I $D(IOP),IOP=$I!(IOP="HOME")!(0[IOP),$D(^XUTL("XQ",$J,"IO")) D HOME K %IS,%Y,%ZIS,%ZISB,%ZISV,IOP Q 25 ;Don't worry about HOME if %ZIS[0 26 D:%ZIS'[0 GETHOME G EXIT^%ZIS1:POP,^%ZIS1 ;Jump to next part 27 ; 28 GETHOME I $D(IO("HOME")),$P(IO("HOME"),"^",2)=IO(0) S (%E,%H)=+IO("HOME") Q 29 I $D(^XUTL("XQ",$J,"IOS")),$D(^("IO")),IO(0)=^("IO") S (%E,%H)=^("IOS") Q 30 ;CALL LINEPORT CODE HERE--- 31 S %=$$LINEPORT^%ZISUTL I % S (%E,%H)=% Q 32 S %ZISVT=$I D VTLKUP I '%E S %ZISVT=$I D VIRTUAL 33 I %ZISVT=""!(%E'>0) I %IS'[0 O IO(0)::0 I $T U IO(0) W !,"HOME DEVICE DOES NOT EXIST IN THE DEVICE FILE",!,"PLEASE CONTACT YOUR SYSTEM MANAGER!",*7 34 S %H=%E S:'%H&(%IS'[0) POP=1 S:(%H>0)&('$D(IO("HOME"))) IO("HOME")=%H_"^"_$I 35 Q 36 VIRTUAL ;See if a Virtual Terminal (LAT, TELNET) 37 ;Change the MSM check for telnet to work with v4.4 38 I %ZISOS["MSM" X "I $P($ZV,""Version "",2)'<3 S %ZISVT=$ZDE(+%ZISVT) I %ZISVT?.E1""~""4.5N.E S %ZISVT=""TELNET""" 39 F %ZISI=$L(%ZISVT):-1:0 D:$D(^%ZIS(1,"C",%ZISVT)) Q:$S('%E:0,'$D(^%ZIS(1,%E,"TYPE")):0,^("TYPE")="VTRM":1,1:0) S %ZISVT=$E(%ZISVT,1,%ZISI) 40 .D VTLKUP Q:$S('%E:0,'$D(^%ZIS(1,%E,"TYPE")):0,^("TYPE")="VTRM":1,1:0) 41 .S %X=0 F %ZISX=%ZISV,"" Q:%X>0 S %X=0 F S %E=+$O(^%ZIS(1,"CPU",%ZISX_"."_%ZISVT,%X)) S %X=%E Q:%E'>0 I $G(^%ZIS(1,+%E,"TYPE"))="VTRM" Q 42 Q 43 VTLKUP F %ZISX=%ZISV,"" S %E=+$O(^%ZIS(1,"G","SYS."_%ZISX_"."_%ZISVT,0)) Q:%E S %E=+$O(^%ZIS(1,"CPU",%ZISX_"."_%ZISVT,0)) Q:%E 44 Q 45 ; 46 CURRENT N POP,%ZIS,%IS,%E,%H 47 S FF="#",SL=24,BS="*8",RM=80,(SUB,XY)="",%IS=0,%ZISOS=$G(^%ZOSF("OS")),%ZISV=$G(^("VOL")),POP=0 48 D GETHOME K %E,%IS,%ZISI,%ZISOS,%ZISV,%ZISVT,%ZISX Q:POP 49 I $D(^%ZIS(1,%H,"SUBTYPE")) S SUB=+^("SUBTYPE") K %H 50 I $D(SUB),SUB,$D(^%ZIS(2,SUB,1)) S SUB=$S($D(^(0)):$P(^(0),"^"),1:""),FF=$P(^(1),"^",2),SL=$P(^(1),"^",3),BS=$P(^(1),"^",4),XY=$P(^(1),"^",5),RM=+^(1) 51 E S SUB="" 52 I $D(^%ZOSF("RM")) N X S X=RM X ^("RM") K %A 53 Q 54 HOME ;Entry point to establish IO* variables for home device. 55 D CLEAN ;(p363) 56 N X I '$D(^XUTL("XQ",$J,"IO")) S IOP="HOME" D ^%ZIS Q 57 D RESETVAR 58 I '$D(IO("C")),$G(IOM),IO=$I,$D(IO(1,IO)),$D(^%ZOSF("RM")) S X=+IOM X ^("RM") 59 Q 60 ;IO("Q") is checked by many routines after a call to ^%ZISC, so only clean on call to %ZIS. 61 CLEAN ;Cleanup env. Called from %ZISC also. 62 K IO("DOC"),IO("HFSIO"),IO("SPOOL") ;(p366) 63 S (IOPAR,IOUPAR)="" 64 Q 65 ; 66 RESETVAR ;Reset home IO* variables. 67 I '$D(^XUTL("XQ",$J,"IO")) Q 68 N % F %="IO","IOBS","IOF","IOM","ION","IOS","IOSL","IOST","IOST(0)","IOT","IOXY" I $D(^XUTL("XQ",$J,%))#2 S @%=^(%) 69 S POP=0,IO(0)=IO,(IOPAR,IOUPAR)="" 70 Q 71 SAVEVAR ;Save home IO* variables, called from XUS1 72 N % F %="IO","IOBS","IOF","IOM","ION","IOS","IOSL","IOST","IOST(0)","IOT","IOXY" I $D(@%) S ^XUTL("XQ",$J,%)=@% 73 Q 74 ZISLPC Q ;No longer called in Kernel v8. 75 ; 76 HLP1 G EN1^%ZIS7 77 HLP2 N %E,%H,%X,%ZISV,X S %ZISV=$S($D(^%ZOSF("VOL")):^("VOL"),1:"") G EN2^%ZIS7 78 ; 79 REWIND(IO2,IOT,IOPAR) ;Rewind Device 80 N %,X,Y,$ES,$ET S $ET="D REWERR^%ZIS Q 0" 81 S %=$I 82 I '($D(IO2)#2)!'$D(IOT)!'$D(IOPAR) Q 0 83 I "MT^SDP^HFS"'[IOT Q 0 84 S @("Y=$$REW"_IOT_"^%ZIS4(IO2,IOPAR)") 85 U % 86 Q Y 87 REWERR ;Error encountered 88 S IO("ERROR")=$EC 89 S $EC="",$ET="Q:$ES>1 S $EC="""" Q 0" S $EC=",U1," 90 Q 0 91 ; -
WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZIS1.m
r613 r623 1 %ZIS1 ;SFISC/AC,RWF -- DEVICE HANDLER (DEVICE INPUT) ;1/24/08 16:06 2 ;;8.0;KERNEL;**18,49,69,104,112,199,391,440**;JUL 10, 1995;Build 13 3 ;Per VHA Directive 2004-038, this routine should not be modified 4 MAIN ;Called from %ZIS with a GO 5 I '$D(IOP),$D(^%ZIS(1,%E,0)),'$P(^(0),"^",3) S %A=%H,%Z=^(0) D L2^%ZIS2 G EXIT 6 L1 ;Main Loop 7 I '$D(IOP),$D(IO("Q")),POP D AQUE^%ZIS3 K:%=2 IO("Q") S:%=2 %ZISB=$S(%IS'["N":2,1:0) I %=-1 S POP=1 G EXIT 8 S %E=%H,POP=0,%IS=%ZIS ;Reset %IS from %ZIS 9 I %IS'["Q",$D(XQNOGO) S POP=1 W:'$D(IOP) !,$C(7),"OUTPUT IS NEVER ALLOWED FOR THIS OPTION" G EXIT 10 D IOP:$D(IOP),R:'$D(IOP) 11 G EXIT:$D(DTOUT)!$D(DUOUT)!(POP&$D(IOP)),L1:POP&'$D(IOP) 12 D LKUP I %A'>0 S POP=1 D:'$D(DUOUT) MSG1 K DUOUT 13 I '$D(^%ZIS(1,%A,0)) D MSG1 K %ZISIOS S POP=1 14 I POP G EXIT:$D(IOP),L1:'$D(IOP) 15 S %E=%A,%Z=^%ZIS(1,%A,0),%Z1=$G(^(1)) 16 I $D(%ZIS("S")) N Y S Y=%E D XS^ZISX S:'$T POP=1 G G:POP 17 W:'$D(IOP)&($P(%Z,"^",2)'=$I)&($P(%Z1,"^")]"") " ",$P(%Z1,"^") 18 D L2^%ZIS2 ;Call 19 G G L1:POP&'$D(IOP)&'($D(DTOUT)!$D(DUOUT)) ;Didn't get it 20 ; 21 EXIT ; 22 I POP G EX2 ;Did not get the device. 23 ;For type[TRM reset $X & $Y 24 I %ZTYPE["TRM",IO]"",$D(IO(1,IO)) U IO S:'(IO=IO(0)&'$D(IO("S"))&'$D(ZTQUEUED)) $X=0,$Y=0 25 ;Do count of number of times device opened. Field 51. 26 I $L($G(IO)),$D(IO(1,IO))#2,$G(%ZISIOS) D 27 . S $P(^(5),"^",1)=$P($G(^%ZIS(1,%ZISIOS,5)),"^",1)+1 28 I %ZIS["H" S IO(0)=IO,IO("HOME")=%ZISIOS_"^"_IO ;Make home device 29 I '$D(IO("Q")),$D(%ZISLOCK) S ^XUTL("XQ",$J,"lock",%ZISIOS)=%ZISLOCK 30 I $D(IO)#2,IO]"",$D(IO(1,IO))#2,$D(%Z1),$P(%Z1,"^",11) S IO(1,IO,"NOFF")=1 31 EX2 ; 32 I %IS'[0,$G(IO(0))]"" U IO(0) ;Make sure return with home active 33 G SETVAR:'POP!(%IS["T"),KILVAR 34 ; 35 IOP ;Request with IOP set 36 S (%ZISVT,%X)=IOP S:%X'?1.UNP %X=$$UP(%X) I %X'="Q" D SETQ Q 37 S %IS=%IS_%X K IOP W %X D SETQ Q 38 ;Get ready to ask user for device 39 R I %IS["Q",$D(XQNOGO) W !,$C(7),"AT THIS TIME, OUTPUT MUST BE QUEUED" 40 S %A=$S($D(%IS("B")):%IS("B"),1:"HOME") ;Setup default 41 I %IS["P",%A="HOME",$D(^%ZIS(1,%E,99)),$D(^%ZIS(1,+^(99),0)) S %A=$P(^(0),"^",1) 42 RD W !,$S($D(%IS("A")):%IS("A"),1:"DEVICE: ") W:%A]"" %A,"// " D SBR S:%X="" %X=%A S %ZISVT=%X 43 I %X?2"?".E D EN2^%ZIS7 G R 44 I %X?1"?".E D EN1^%ZIS7 G R 45 I $D(DTOUT)!$D(DUOUT)!(%X'?.ANP)!($L($P(%X,";"))>31) S:%IS["T" IO="" S POP=1 Q 46 S:%X'?1.UNP %X=$$UP(%X) D SETQ G R:$T Q 47 SETQ S %Y=$P(%X,";",2,9),%X=$P(%X,";",1) S:$L(";"_%Y,";/")=2 IO("P")=$P(";"_%Y,";/",2) 48 I %IS["Q",%X="Q" S %X=%Y,%ZISVT=$P(%ZISVT,";",2,9),%ZISB=0,IO("Q")=1,%IS("A")="DEVICE: " S:$D(IOP) %Y=$P(%X,";",2,9),%X=$P(%X,";",1) 49 I $T,'$D(IOP) W "UEUE TO PRINT ON" Q ; Return $T value 50 Q 51 LKUP S %ZISMY=$P(%ZISVT,";",2,999),%ZISVT=$P(%ZISVT,";") 52 I %X="H" W:'$D(IOP) "ome" S %X=0 53 I 0[%X!(%X="HOME")!(%X=$I) S %A=%H Q 54 I $E(%ZISVT)="`",$D(IOP) S %A=+$E(%ZISVT,2,999) I $G(^%ZIS(1,%A,0))]"" Q 55 S %A=0 I "P"[%X Q:$D(IOP)&('$D(^%ZIS(1,%E,99))) I $D(^%ZIS(1,%E,99)) S %A=+^(99) Q 56 I %X=" ",$D(DUZ)#2,$D(^DISV(+DUZ,"^%ZIS(1,")) S %A=^("^%ZIS(1,") Q 57 S %A=+$O(^%ZIS(1,"B",%ZISVT,0)) Q:%A>0 ;mixed case lookup 58 I %X'=%ZISVT S %A=+$O(^%ZIS(1,"B",%X,0)) Q:%A>0 ;uppercase lookup 59 D VTLKUP^%ZIS S %A=%E Q:%A>0 ;mixed case lookup 60 I %X'=%ZISVT S %ZISVT=%X D VTLKUP^%ZIS S %A=%E Q:%A>0 ;uppercase lookup 61 N %XX,%YY S %XX=%X D 1^%ZIS5 S %A=+%YY Q 62 SBR K DFOUT,DTOUT,DUOUT R %X:$S($D(DTIME)#2:DTIME,1:300) E W $C(7) S DTOUT=1 Q 63 S:%X="."!(%X="^") DUOUT=1,%X="" Q 64 LC S %X=$$UP(%X) 65 Q 66 LOW(%) Q $TR(%,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz") 67 UP(%) Q $TR(%,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") 68 ; 69 ;Call/Return % = 1 (yes), 2 (no) -1 (^) 70 YN W "? ",$P("Yes// ^No// ",U,%) 71 RYN R %X:$S($D(DTIME):DTIME,$D(%ZISDTIM):%ZISDTIM,1:300) E S DTOUT=1,%X=U W $C(7) 72 S:%X]""!'% %=$A(%X),%=$S(%=89:1,%=121:1,%=78:2,%=110:2,%=94:-1,1:0) 73 I '%,%X'?."?" W $C(7),"??",!?4,"ANSWER 'Yes' OR 'No': " G RYN 74 W:$X>73 ! W $P(" (Yes)^ (No)",U,%) 75 Q 76 MSG1 I '$D(IOP) W ?20,$C(7)," [DEVICE DOES NOT EXIST]" 77 Q 78 SETVAR ;Come here to setup the variables for the selected device 79 S:$D(IO)[0 IO="" G KILVAR:%IS["T"&(IO="") 80 I $G(%Z)="" S ION="Unknown device",POP=1 G KILVAR 81 S:IO'=IO(0)&($D(DUZ)#2) ^DISV(+DUZ,"^%ZIS(1,")=%E 82 S ION=$P(%Z,"^",1),IOM=+%Z91,IOF=$P(%Z91,"^",2),IOSL=$P(%Z91,"^",3),IOBS=$P(%Z91,"^",4),IOXY=$P(%Z91,"^",5) 83 I IOSL>65530 S IOSL=65530 ;Cache rolls $Y at 65535 84 S IOT=%ZTYPE,IOST(0)=%ZISIOST(0),IOST=%ZISIOST,IOPAR=%ZISOPAR,IOUPAR=%ZISUPAR,IOHG=%ZISHG 85 S:IOF="" IOF="#" ;See that IOF has something 86 K IOCPU S:$D(%ZISCPU) IOCPU=%ZISCPU 87 G KIL 88 ; 89 KILVAR ;Come here to restore the calling variables 90 D SYMBOL^%ZISUTL(1,"%ZISOLD") 91 S:'$L($G(IOF)) IOF="#" S:'$D(IOST(0)) IOST(0)=0 92 ;See that all standard variables are defined 93 F %I="IO","ION","IOM","IOBS","IOSL","IOST" S:$D(@%I)[0 @%I="" 94 K IO("HFSIO"),IO("OPEN") I $D(%ZISCPU) S:'$D(IOCPU) IOCPU=%ZISCPU 95 KIL ;Final exit cleanup 96 S:'POP IOS=%ZISIOS I POP K:%IS'["T" %ZISIOS I %IS["T" K IOS S:$D(%ZISIOS) IOS=%ZISIOS 97 S:%IS["T" IO("T")=1 K %ZIS,%IS,%A,%E,%H,%ZISOS,%ZISV,IOP 98 K2 K %I,%X,%Y,%Z,%Z1,%Z91,%Z95,%ZTYPE,%ZTIME 99 K %ZISCHK,%ZISCPU,%ZISI,%ZISR,%ZISVT,%ZISB,%ZISX,ZISI,%ZISHGL,%ZISHP,%ZISIO,%ZISIOS,%ZISIOM 100 K %ZISIOF,%ZISIOSL,%ZISIOBS,%ZISIOST,%ZISIOST(0),%ZISTO,%ZISTP,%ZISHG,%ZISSIO,%ZISOPEN,%ZISOPAR,%ZISUPAR 101 K %ZISMY,%ZISQUIT,%ZISLOCK 102 Q 1 %ZIS1 ;SFISC/AC,RWF -- DEVICE HANDLER (DEVICE INPUT) ;07/07/2005 15:48 2 ;;8.0;KERNEL;**18,49,69,104,112,199,391**;JUL 10, 1995 3 MAIN ;Called from %ZIS with a GO 4 I '$D(IOP),$D(^%ZIS(1,%E,0)),'$P(^(0),"^",3) S %A=%H,%Z=^(0) D L2^%ZIS2 G EXIT 5 L1 ;Main Loop 6 I '$D(IOP),$D(IO("Q")),POP D AQUE^%ZIS3 K:%=2 IO("Q") S:%=2 %ZISB=$S(%IS'["N":2,1:0) I %=-1 S POP=1 G EXIT 7 S %E=%H,POP=0,%IS=%ZIS ;Reset %IS from %ZIS 8 I %IS'["Q",$D(XQNOGO) S POP=1 W:'$D(IOP) !,*7,"OUTPUT IS NEVER ALLOWED FOR THIS OPTION" G EXIT 9 D IOP:$D(IOP),R:'$D(IOP) 10 G EXIT:$D(DTOUT)!$D(DUOUT)!(POP&$D(IOP)),L1:POP&'$D(IOP) 11 D LKUP I %A'>0 S POP=1 D:'$D(DUOUT) MSG1 K DUOUT 12 I POP G EXIT:$D(IOP),L1:'$D(IOP) 13 I '$D(^%ZIS(1,%A,0)) D MSG1 K %ZISIOS S POP=1 14 I POP G EXIT:$D(IOP),L1:'$D(IOP) 15 S %E=%A,%Z=^%ZIS(1,%A,0),%Z1=$G(^(1)) 16 I $D(%ZIS("S")) N Y S Y=%E D XS^ZISX S:'$T POP=1 G G:POP 17 W:'$D(IOP)&($P(%Z,"^",2)'=$I)&($P(%Z1,"^")]"") " ",$P(%Z1,"^") 18 D L2^%ZIS2 19 G G L1:POP&'$D(IOP)&'($D(DTOUT)!$D(DUOUT)) ;Didn't get it 20 ;For type[TRM reset $X & $Y 21 I 'POP,%ZTYPE["TRM",IO]"",$D(IO(1,IO)) U IO S:'(IO=IO(0)&'$D(IO("S"))&'$D(ZTQUEUED)) $X=0,$Y=0 22 ; 23 EXIT I $D(IO)#2,IO]"",$D(IO(1,IO))#2,$D(%Z1),$P(%Z1,"^",11) S IO(1,IO,"NOFF")=1 24 ;Do count of number of times device opened. Field 51. 25 I $L($G(IO)),$D(IO(1,IO))#2,'POP,$G(%ZISIOS) D 26 . S $P(^(5),"^",1)=$P($G(^%ZIS(1,%ZISIOS,5)),"^",1)+1 27 I 'POP,%ZIS["H" S IO(0)=IO,IO("HOME")=%ZISIOS_"^"_IO ;Make home device 28 I %IS'[0,$G(IO(0))]"" U IO(0) ;Make sure return with home active 29 G SETVAR:'POP!(%IS["T"),KILVAR 30 ; 31 IOP ;Request with IOP set 32 S (%ZISVT,%X)=IOP S:%X'?1.UNP %X=$$UP(%X) I %X'="Q" D SETQ Q 33 S %IS=%IS_%X K IOP W %X D SETQ Q 34 ;Get ready to ask user for device 35 R I %IS["Q",$D(XQNOGO) W !,*7,"AT THIS TIME, OUTPUT MUST BE QUEUED" 36 S %A=$S($D(%IS("B")):%IS("B"),1:"HOME") ;Setup default 37 I %IS["P",%A="HOME",$D(^%ZIS(1,%E,99)),$D(^%ZIS(1,+^(99),0)) S %A=$P(^(0),"^",1) 38 RD W !,$S($D(%IS("A")):%IS("A"),1:"DEVICE: ") W:%A]"" %A,"// " D SBR S:%X="" %X=%A S %ZISVT=%X 39 I %X?2"?".E D EN2^%ZIS7 G R 40 I %X?1"?".E D EN1^%ZIS7 G R 41 I $D(DTOUT)!$D(DUOUT)!(%X'?.ANP)!($L($P(%X,";"))>31) S:%IS["T" IO="" S POP=1 Q 42 S:%X'?1.UNP %X=$$UP(%X) D SETQ G R:$T Q 43 SETQ S %Y=$P(%X,";",2,9),%X=$P(%X,";",1) S:$L(";"_%Y,";/")=2 IO("P")=$P(";"_%Y,";/",2) 44 I %IS["Q",%X="Q" S %X=%Y,%ZISVT=$P(%ZISVT,";",2,9),%ZISB=0,IO("Q")=1,%IS("A")="DEVICE: " S:$D(IOP) %Y=$P(%X,";",2,9),%X=$P(%X,";",1) 45 I $T,'$D(IOP) W "UEUE TO PRINT ON" Q ; Return $T value 46 Q 47 LKUP S %ZISMY=$P(%ZISVT,";",2,999),%ZISVT=$P(%ZISVT,";") 48 I %X="H" W:'$D(IOP) "ome" S %X=0 49 I 0[%X!(%X="HOME")!(%X=$I) S %A=%H Q 50 I $E(%ZISVT)="`",$D(IOP) S %A=+$E(%ZISVT,2,999) I $G(^%ZIS(1,%A,0))]"" Q 51 S %A=0 I "P"[%X Q:$D(IOP)&('$D(^%ZIS(1,%E,99))) I $D(^%ZIS(1,%E,99)) S %A=+^(99) Q 52 I %X=" ",$D(DUZ)#2,$D(^DISV(+DUZ,"^%ZIS(1,")) S %A=^("^%ZIS(1,") Q 53 S %A=+$O(^%ZIS(1,"B",%ZISVT,0)) Q:%A>0 ;mixed case lookup 54 I %X'=%ZISVT S %A=+$O(^%ZIS(1,"B",%X,0)) Q:%A>0 ;uppercase lookup 55 D VTLKUP^%ZIS S %A=%E Q:%A>0 ;mixed case lookup 56 I %X'=%ZISVT S %ZISVT=%X D VTLKUP^%ZIS S %A=%E Q:%A>0 ;uppercase lookup 57 N %XX,%YY S %XX=%X D 1^%ZIS5 S %A=+%YY Q 58 SBR K DFOUT,DTOUT,DUOUT R %X:$S($D(DTIME)#2:DTIME,1:300) E W *7 S DTOUT=1 Q 59 S:%X="."!(%X="^") DUOUT=1,%X="" Q 60 LC S %X=$$UP(%X) 61 Q 62 LOW(%) Q $TR(%,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz") 63 UP(%) Q $TR(%,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") 64 YN W "? ",$P("YES// ^NO// ",U,%) 65 RYN R %X:$S($D(DTIME):DTIME,$D(%ZISDTIM):%ZISDTIM,1:300) E S DTOUT=1,%X=U W *7 66 S:%X]""!'% %=$A(%X),%=$S(%=89:1,%=121:1,%=78:2,%=110:2,%=94:-1,1:0) 67 I '%,%X'?."?" W *7,"??",!?4,"ANSWER 'YES' OR 'NO': " G RYN 68 W:$X>73 ! W $P(" (YES)^ (NO)",U,%) Q 69 MSG1 I '$D(IOP) W ?20,*7," [DEVICE DOES NOT EXIST]" 70 Q 71 SETVAR ;Come here to setup the variables for the selected device 72 S:$D(IO)[0 IO="" G KILVAR:%IS["T"&(IO="") 73 I $G(%Z)="" S ION="Unknown device",POP=1 G KILVAR 74 S:IO'=IO(0)&($D(DUZ)#2) ^DISV(+DUZ,"^%ZIS(1,")=%E 75 S ION=$P(%Z,"^",1),IOM=+%Z91,IOF=$P(%Z91,"^",2),IOSL=$P(%Z91,"^",3),IOBS=$P(%Z91,"^",4),IOXY=$P(%Z91,"^",5) 76 I IOSL>65530 S IOSL=65530 ;Cache rolls $Y at 65535 77 S IOT=%ZTYPE,IOST(0)=%ZISIOST(0),IOST=%ZISIOST,IOPAR=%ZISOPAR,IOUPAR=%ZISUPAR,IOHG=%ZISHG 78 S:IOF="" IOF="#" ;See that IOF has something 79 K IOCPU S:$D(%ZISCPU) IOCPU=%ZISCPU G KIL 80 ; 81 KILVAR ;Come here to restore the calling variables 82 D SYMBOL^%ZISUTL(1,"%ZISOLD") 83 S:'$L($G(IOF)) IOF="#" S:'$D(IOST(0)) IOST(0)=0 84 ;See that all standard variables are defined 85 F %I="IO","ION","IOM","IOBS","IOSL","IOST" S:$D(@%I)[0 @%I="" 86 K IO("HFSIO"),IO("OPEN") I $D(%ZISCPU) S:'$D(IOCPU) IOCPU=%ZISCPU 87 KIL ;Final exit cleanup 88 S:'POP IOS=%ZISIOS I POP K:%IS'["T" %ZISIOS I %IS["T" K IOS S:$D(%ZISIOS) IOS=%ZISIOS 89 S:%IS["T" IO("T")=1 K %ZIS,%IS,%A,%E,%H,%ZISOS,%ZISV,IOP 90 K2 K %I,%X,%Y,%Z,%Z1,%Z91,%Z95,%ZTYPE,%ZTIME 91 K %ZISCHK,%ZISCPU,%ZISI,%ZISR,%ZISVT,%ZISB,%ZISX,ZISI,%ZISHGL,%ZISHP,%ZISIO,%ZISIOS,%ZISIOM,%ZISIOF,%ZISIOSL,%ZISIOBS,%ZISIOST,%ZISIOST(0),%ZISTO,%ZISTP,%ZISHG,%ZISSIO,%ZISOPEN,%ZISOPAR,%ZISUPAR 92 K %ZISMY,%ZISQUIT 93 Q -
WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZIS2.m
r613 r623 1 %ZIS2 ;SFISC/AC,RWF -- DEVICE HANDLER (CHECKS) ;1/24/08 16:07 2 ;;8.0;KERNEL;**69,104,112,118,136,241,440**;JUL 10, 1995;Build 13 3 ;Per VHA Directive 2004-038, this routine should not be modified 4 HUNT S:'$D(%ZISHP) %ZISHP=%E,%ZISHGL=0 S %E=0 5 F S %ZISHGL=$O(^%ZIS(1,%ZISHG(0),"HG",%ZISHGL)) Q:%ZISHGL'>0 D Q:%E 6 . N %1,%2 S %1=$G(^%ZIS(1,%ZISHG(0),"HG",+%ZISHGL,0)),%2=$G(^%ZIS(1,+%1,0)) 7 . ;Check that HG device is on same VOL. 8 . I $P(%2,"^",9)=%ZISV!($P(%2,"^",9)="") S %E=+$P(^%ZIS(1,%ZISHG(0),"HG",+%ZISHGL,0),"^") 9 . Q 10 G L2:%ZISHGL>0 S %ZISHPOP=1,%E=%ZISHP 11 ; 12 L2 ;Entry point from %ZIS1 13 I $D(DTOUT)!$D(DUOUT) K %ZISHP,%ZISHPOP Q 14 CHECK ;Get IO check for secondary $I 15 K %ZISCPU N %Z2 16 S POP=0,%Z=^%ZIS(1,%E,0),%Z2=$S(%ZIS("PRI")=1:"",1:$G(^%ZIS(1,%E,2))) ;Get Primary and secondary IO. 17 S IO=$S(%ZIS("PRI")=1:$P(%Z,"^",2),$L($P(%Z2,"^")):$P(%Z2,"^"),1:$P(%Z,"^",2)) ; 18 S:%IS["Q"&'$D(ZTQUEUED)&($P(%Z,"^",12)=1!$D(XQNOGO)) %ZISB=0,IO("Q")=1 ;Forced Queueing 19 I $P(%Z,"^",12)=2 S %IS=$TR(%IS,"Q") I $D(IO("Q")) D Q 20 . I '$D(IOP) W !,"Queuing NOT ALLOWED on this device" 21 . S POP=1 K:$D(IOP) IO("Q") Q 22 S %Z90=$G(^(90)),%Z95=$G(^(95)),%ZTIME=$G(^("TIME")),%ZTYPE=$G(^("TYPE")),%ZISHG=$O(^%ZIS(1,"AHG",%E,0)) 23 I %ZISHG,$D(^%ZIS(1,+%ZISHG,0)) S:'$D(%ZISHG(0)) %ZISHG(0)=+%ZISHG S %ZISHG=$P(^(0),"^",1) 24 E S %ZISHG="" 25 I %ZTYPE="HG" D OTHCPU("HUNT GROUP") G T:$D(%ZISHG(0))!POP 26 I %ZTYPE="RES" S %ZISRL=+$P(%Z1,"^",10) G T 27 VTRM I %ZTYPE="VTRM",'('$D(IO("Q"))&(%A=%H)) W:'$D(IOP)&'$D(%ZISHP) *7," [YOU CAN NOT SELECT A VIRTUAL TERMINAL]" S POP=1 ;Virtual Terminal Check 28 S:%ZTYPE="VTRM"&'$D(IO("Q"))&(%A=%H) IO=$I 29 ; 30 SLAVE I $D(IO("Q")),$P(%Z,"^",2)=0,$P(%Z,"^",8)']"" W:'$D(IOP) *7,!?10," [SLAVE device NOT set up for queuing]" S POP=1 G T 31 OCPU D OTHCPU("DEVICE") 32 ; 33 OOS G T:POP I %Z90,$D(DT)#2,%Z90'>DT S POP=1 ;Out Of Service Check 34 I $T,'$D(IOP),'$D(%ZISHP) W *7," [Out of Service]" ;I 'POP W " ..OK" S %=2,U="^" D YN^%ZIS1 G:%=0 OOS S:%'=1 POP=1 35 ; 36 PTIME G T:POP!(IO=$I)!(IO=0) 37 ;Prohibitted Time Check 38 S %A=$P(%ZTIME,"^") I %ZISB,$L(%A) D I POP,'$D(IOP),'$D(%ZISHP) W *7," [ACCESS PROHIBITED "_%A_"]" ;AT THIS TIME]" 39 . N %C,%L,%H ;%C is current time, %L is lower limit, %H is upper limit 40 . S %C=$P($H,",",2),%C=%C\60#60+(%C\3600*100),%H=$P(%A,"-",2),%L=+%A 41 . I $S(%H'<%L:(%C'>%H&(%C'<%L)),1:(%C'<%L!(%C'>%H))) S POP=1 42 . Q 43 DUZ I 'POP D SEC ;Security Check 44 ; 45 T I POP,$D(%ZISHG(0)),%IS'["D",'$D(%ZISHPOP),%ZISB G HUNT 46 I POP D HGBSY:$D(%ZISHPOP) ;G T2:%IS["T" 47 ; 48 TMPVAR K IO("S") S %ZISIOS=%E S:IO=0 IO=$I,IO("S")=%H 49 S %ZISOPAR=$$IOPAR(%E,"IOPAR") 50 S %ZISUPAR=$$IOPAR(%E,"IOUPAR"),%ZISTO=+$P(%ZTIME,"^",2) 51 I $D(IO("S")) D I POP Q 52 . S IO=$S(%IS["S":$P($G(^%ZIS(1,+$P(%Z,"^",8),0)),"^",2),1:IO) 53 . I %IS["S",IO]"" S %H=+$P(%Z,"^",8),IO("S")=%H,IO(0)=IO 54 . S IO("S")=$S($G(^XUTL("XQ",$J,"IOST(0)")):^("IOST(0)"),1:$G(^%ZIS(1,%H,"SUBTYPE"))) 55 . S:IO="" POP=1 56 . Q 57 S %A=+$G(^%ZIS(1,%E,"SUBTYPE")),%ZISTP=0 ;%A is pointer to subtype 58 I %E=%H,%ZTYPE["TRM" D I 1 59 . I $D(^XUTL("XQ",$J,"IOST(0)")) D ;Use home 60 . . S %A=+^XUTL("XQ",$J,"IOST(0)"),%Z91="",%ZISTP=1 61 . . F %ZISI="IOM","IOF","IOSL","IOBS","IOXY" S %Z91=%Z91_$G(^XUTL("XQ",$J,%ZISI))_"^" 62 . E S %=$$LNPRTSUB^%ZISUTL I %>0 S %A=%,%Z91="" 63 E S %Z91=$P($G(^%ZIS(2,%A,1)),"^",1,4),$P(%Z91,"^",5)=$G(^("XY")) 64 ;I $D(%Z91),%Z91'?1.4"^" ;$P(%Z91,"^")]"",$P(%Z91,"^",2)]"",$P(%Z91,"^",3),$P(%Z91,"^",4)]"" 65 D ST^%ZIS3(%ZISTP) S:%IS["U" USIO=$P(%Z91,"^",1,4) 66 T2 I POP S:%IS'["T" IO="" Q 67 G ^%ZIS3:"^MTRM^VTRM^TRM^SPL^MT^SDP^HFS^RES^OTH^BAR^HG^IMPC^CHAN^"[("^"_%ZTYPE_"^") ;Jump to next part 68 S POP=1 Q 69 ; 70 HGBSY S POP=1 S:%IS'["T" IO="" K %ZISHP,%ZISHPOP Q:$D(IOP) 71 W:$X>38 !,?5 W *7," All devices in hunt group "_%ZISHG_" are busy!" Q 72 ; 73 OTHCPU(%1) ;%1 should be either DEVICE or HUNT GROUP 74 N %2,X,Y,%ZISMSG S %ZISMSG=0 75 F %2="CPU","VOLUME SET" D 76 .I %2="VOLUME SET" S X=$P($P(%Z,"^",9),":"),Y=%ZISV 77 .E D GETENV^%ZOSV S X=$P($P(%Z,"^",9),":",2),Y=$P($P(Y,"^",4),":",2) 78 .I X=Y!(X="") Q:%1="DEVICE" D Q ;Other Vol Set/Cpu Check 79 ..S %ZISHG(0)=%E,%ZISHG=$P(%Z,"^") 80 ..I %ZISB S POP=1 81 ..E S IO=" " 82 .I %2="VOLUME SET" S $P(%ZISCPU,":")=X 83 .E S $P(%ZISCPU,":",2)=X 84 .I %1="HUNT GROUP" K %ZISHG(0) 85 .I %IS["Q" S IO("Q")=1,%ZISB=0 S:%1="HUNT GROUP" IO=" " 86 .E I %ZISB&(%ZTYPE="TRM"&($D(%ZISHG(0))&(%IS'["D"))) S POP=1 87 .E W:'$D(IOP)&'%ZISMSG *7," ["_%1_" is on another "_%2_" ('"_X_"')]",! S POP=1,%ZISMSG=1 88 Q 89 IOPAR(%DA,%N) ;Return I/O parameters 90 Q $S($G(%ZIS(%N))]"":%ZIS(%N),1:$G(^%ZIS(1,%DA,%N))) 91 ; 92 SEC I %Z95]"" S %X=$G(DUZ(0)) I %X'="@" S POP=1 F %A=1:1:$L(%X) I %Z95[$E(%X,%A) S POP=0 Q 93 I POP,'$D(IOP),'$D(%ZISHP) W *7," [Access Prohibited]" 94 Q 1 %ZIS2 ;SFISC/AC,RWF -- DEVICE HANDLER (CHECKS) ;06/12/2002 15:41 2 ;;8.0;KERNEL;**69,104,112,118,136,241**;JUL 10, 1995 3 HUNT S:'$D(%ZISHP) %ZISHP=%E,%ZISHGL=0 S %E=0 4 F S %ZISHGL=$O(^%ZIS(1,%ZISHG(0),"HG",%ZISHGL)) Q:%ZISHGL'>0 D Q:%E 5 . N %1,%2 S %1=$G(^%ZIS(1,%ZISHG(0),"HG",+%ZISHGL,0)),%2=$G(^%ZIS(1,+%1,0)) 6 . ;Check that HG device is on same VOL. 7 . I $P(%2,"^",9)=%ZISV!($P(%2,"^",9)="") S %E=+$P(^%ZIS(1,%ZISHG(0),"HG",+%ZISHGL,0),"^") 8 . Q 9 G L2:%ZISHGL>0 S %ZISHPOP=1,%E=%ZISHP 10 ; 11 L2 ;Entry point from %ZIS1 12 I $D(DTOUT)!$D(DUOUT) K %ZISHP,%ZISHPOP Q 13 CHECK K %ZISCPU S POP=0,%Z=^%ZIS(1,%E,0),IO=$P(%Z,"^",2) 14 S:%IS["Q"&'$D(ZTQUEUED)&($P(%Z,"^",12)=1!$D(XQNOGO)) %ZISB=0,IO("Q")=1 ;Forced Queueing 15 I $P(%Z,"^",12)=2 S %IS=$TR(%IS,"Q") I $D(IO("Q")) D Q 16 . I '$D(IOP) W !,"Queuing NOT ALLOWED on this device" 17 . S POP=1 K:$D(IOP) IO("Q") Q 18 S %Z90=$G(^(90)),%Z95=$G(^(95)),%ZTIME=$G(^("TIME")),%ZTYPE=$G(^("TYPE")),%ZISHG=$O(^%ZIS(1,"AHG",%E,0)) 19 I %ZISHG,$D(^%ZIS(1,+%ZISHG,0)) S:'$D(%ZISHG(0)) %ZISHG(0)=+%ZISHG S %ZISHG=$P(^(0),"^",1) 20 E S %ZISHG="" 21 I %ZTYPE="HG" D OTHCPU("HUNT GROUP") G T:$D(%ZISHG(0))!POP 22 I %ZTYPE="RES" S %ZISRL=+$P(%Z1,"^",10) G T 23 VTRM I %ZTYPE="VTRM",'('$D(IO("Q"))&(%A=%H)) W:'$D(IOP)&'$D(%ZISHP) *7," [YOU CAN NOT SELECT A VIRTUAL TERMINAL]" S POP=1 ;Virtual Terminal Check 24 S:%ZTYPE="VTRM"&'$D(IO("Q"))&(%A=%H) IO=$I 25 ; 26 SLAVE I $D(IO("Q")),$P(%Z,"^",2)=0,$P(%Z,"^",8)']"" W:'$D(IOP) *7,!?10," [SLAVE device NOT set up for queuing]" S POP=1 G T 27 OCPU D OTHCPU("DEVICE") 28 ; 29 OOS G T:POP I %Z90,$D(DT)#2,%Z90'>DT S POP=1 ;Out Of Service Check 30 I $T,'$D(IOP),'$D(%ZISHP) W *7," [Out of Service]" ;I 'POP W " ..OK" S %=2,U="^" D YN^%ZIS1 G:%=0 OOS S:%'=1 POP=1 31 ; 32 PTIME G T:POP!(IO=$I)!(IO=0) 33 ;Prohibitted Time Check 34 S %A=$P(%ZTIME,"^") I %ZISB,$L(%A) D I POP,'$D(IOP),'$D(%ZISHP) W *7," [ACCESS PROHIBITED "_%A_"]" ;AT THIS TIME]" 35 . N %C,%L,%H ;%C is current time, %L is lower limit, %H is upper limit 36 . S %C=$P($H,",",2),%C=%C\60#60+(%C\3600*100),%H=$P(%A,"-",2),%L=+%A 37 . I $S(%H'<%L:(%C'>%H&(%C'<%L)),1:(%C'<%L!(%C'>%H))) S POP=1 38 . Q 39 DUZ I 'POP D SEC ;Security Check 40 ; 41 T I POP,$D(%ZISHG(0)),%IS'["D",'$D(%ZISHPOP),%ZISB G HUNT 42 I POP D HGBSY:$D(%ZISHPOP) ;G T2:%IS["T" 43 ; 44 TMPVAR K IO("S") S %ZISIOS=%E S:IO=0 IO=$I,IO("S")=%H 45 S %ZISOPAR=$$IOPAR(%E,"IOPAR") 46 S %ZISUPAR=$$IOPAR(%E,"IOUPAR"),%ZISTO=+$P(%ZTIME,"^",2) 47 I $D(IO("S")) D I POP Q 48 . S IO=$S(%IS["S":$P($G(^%ZIS(1,+$P(%Z,"^",8),0)),"^",2),1:IO) 49 . I %IS["S",IO]"" S %H=+$P(%Z,"^",8),IO("S")=%H,IO(0)=IO 50 . S IO("S")=$S($G(^XUTL("XQ",$J,"IOST(0)")):^("IOST(0)"),1:$G(^%ZIS(1,%H,"SUBTYPE"))) 51 . S:IO="" POP=1 52 . Q 53 S %A=+$G(^%ZIS(1,%E,"SUBTYPE")),%ZISTP=0 ;%A is pointer to subtype 54 I %E=%H,%ZTYPE["TRM" D I 1 55 . I $D(^XUTL("XQ",$J,"IOST(0)")) D ;Use home 56 . . S %A=+^XUTL("XQ",$J,"IOST(0)"),%Z91="",%ZISTP=1 57 . . F %ZISI="IOM","IOF","IOSL","IOBS","IOXY" S %Z91=%Z91_$G(^XUTL("XQ",$J,%ZISI))_"^" 58 . E S %=$$LNPRTSUB^%ZISUTL I %>0 S %A=%,%Z91="" 59 E S %Z91=$P($G(^%ZIS(2,%A,1)),"^",1,4),$P(%Z91,"^",5)=$G(^("XY")) 60 ;I $D(%Z91),%Z91'?1.4"^" ;$P(%Z91,"^")]"",$P(%Z91,"^",2)]"",$P(%Z91,"^",3),$P(%Z91,"^",4)]"" 61 D ST^%ZIS3(%ZISTP) S:%IS["U" USIO=$P(%Z91,"^",1,4) 62 T2 I POP S:%IS'["T" IO="" Q 63 G ^%ZIS3:"^MTRM^VTRM^TRM^SPL^MT^SDP^HFS^RES^OTH^BAR^HG^IMPC^CHAN^"[("^"_%ZTYPE_"^") ;Jump to next part 64 S POP=1 Q 65 ; 66 HGBSY S POP=1 S:%IS'["T" IO="" K %ZISHP,%ZISHPOP Q:$D(IOP) 67 W:$X>38 !,?5 W *7," All devices in hunt group "_%ZISHG_" are busy!" Q 68 ; 69 OTHCPU(%1) ;%1 should be either DEVICE or HUNT GROUP 70 N %2,X,Y,%ZISMSG S %ZISMSG=0 71 F %2="CPU","VOLUME SET" D 72 .I %2="VOLUME SET" S X=$P($P(%Z,"^",9),":"),Y=%ZISV 73 .E D GETENV^%ZOSV S X=$P($P(%Z,"^",9),":",2),Y=$P($P(Y,"^",4),":",2) 74 .I X=Y!(X="") Q:%1="DEVICE" D Q ;Other Vol Set/Cpu Check 75 ..S %ZISHG(0)=%E,%ZISHG=$P(%Z,"^") 76 ..I %ZISB S POP=1 77 ..E S IO=" " 78 .I %2="VOLUME SET" S $P(%ZISCPU,":")=X 79 .E S $P(%ZISCPU,":",2)=X 80 .I %1="HUNT GROUP" K %ZISHG(0) 81 .I %IS["Q" S IO("Q")=1,%ZISB=0 S:%1="HUNT GROUP" IO=" " 82 .E I %ZISB&(%ZTYPE="TRM"&($D(%ZISHG(0))&(%IS'["D"))) S POP=1 83 .E W:'$D(IOP)&'%ZISMSG *7," ["_%1_" is on another "_%2_" ('"_X_"')]",! S POP=1,%ZISMSG=1 84 Q 85 IOPAR(%DA,%N) ;Return I/O parameters 86 Q $S($G(%ZIS(%N))]"":%ZIS(%N),1:$G(^%ZIS(1,%DA,%N))) 87 ; 88 SEC I %Z95]"" S %X=$G(DUZ(0)) I %X'="@" S POP=1 F %A=1:1:$L(%X) I %Z95[$E(%X,%A) S POP=0 Q 89 I POP,'$D(IOP),'$D(%ZISHP) W *7," [Access Prohibited]" 90 Q -
WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZIS3.m
r613 r623 1 %ZIS3 ;SFISC/AC,RWF -- DEVICE HANDLER(DEVICE TYPES & PARAMETERS) ;1/24/08 13:18 2 ;;8.0;KERNEL;**18,36,69,104,391,440**;JUL 10, 1995;Build 13 3 ;Per VHA Directive 2004-038, this routine should not be modified 4 ;Call with a Go from ^%ZIS2 5 I %ZIS'["T",$G(^%ZIS(1,+%E,"POX"))]"" D XPOX^ZISX(%E) ;Pre-Open 6 I $D(%ZISQUIT) S POP=1 K %ZISQUIT 7 S %ZISCHK=1 8 ;I 'POP&(%ZISB)&(%ZTYPE'="RES")&(%ZTYPE'="OTH")&(%ZTYPE'="SDP")&(IO'["::") D DEVOK 9 ;See if need to lock. 10 K %ZISLOCK 11 I %ZIS'["T",+$G(^%ZIS(1,+%E,"GBL")) S %ZISLOCK=$NA(^%ZIS("lock",IO)) 12 ; 13 I 'POP G TRM:(%ZTYPE["TRM"),@(%ZTYPE_"^%ZIS6") ;Jump to next part 14 ; 15 Q ;%ZIS6 Returns here 16 ;See if need to un-lock. 17 I $D(%ZISUOUT) K %ZISUOUT,%ZISHP,%ZISHPOP Q 18 I $D(%ZISHPOP)&$S(IO="":1,1:'$D(IO(1,IO))) D HGBSY^%ZIS2 Q 19 I POP S:%ZIS'["T" IO="" I $D(%ZISHG(0)),%ZIS'["D",'$D(%ZISHPOP) G HUNT^%ZIS2 20 Q ;Return to %ZIS1 21 ; 22 VTRM ;Virtual terminal type 23 TRM ;D OPEN^%ZIS4:'POP&(%ZISB&(%ZIS'["T")),MARGN:'POP,SETPAR:'POP ;Terminal type 24 D MARGN:'POP,SETPAR:'POP ;Terminal type// TEST CHANGE 25 I 'POP,%ZIS'["T",%ZISB=1,'$D(IOP),IO'=IO(0),'$D(IO("Q")),%ZIS["Q" D AQUE 26 W:'$D(IOP) ! 27 I '$D(IO("Q")),'POP,%ZISB,%ZIS'["T" D O^%ZIS4 28 G Q 29 DEVOK N X,Y,X1 ;Not sure this is needed 30 S X=IO,X1=%ZTYPE 31 D DEVOK^%ZOSV I Y=-99!(Y=0)!(Y=$J) Q 32 I Y>0 S POP=1 W:'$D(IOP)&('$D(%ZISHG(0))!(%IS["D")) !,$C(7),"[Device Unavailable]" Q 33 I Y=-1 S IO="",POP=1 W:'$D(IOP)&('$D(ZISHG(0))!(%IS["D")) !,$C(7),"[Device does not Exist or Unavailable]" Q 34 Q 35 ; 36 MARGN ;Get the margin and page length 37 S %A=$P(%Y,";",1) 38 I %A?1A.ANP D SUBIEN(.%A,1) I $D(^%ZIS(2,%A,1)) K %Z91 D ST(1) S %Y=$P(%Y,";",2,9),%ZISMY=$P(%ZISMY,";",2,9) G MARGN 39 I %A>3 S $P(%Z91,"^")=$S(%A>255:255,1:+%A) 40 I $P(%Y,";",2) S $P(%Z91,"^",3)=+$S($P(%Y,";",2)>65530:65530,1:$P(%Y,";",2)) ;Cache fix for $Y#65535 wrap 41 ; 42 ALTP I '$D(IO("P")) Q:%A>3 G ASKMAR:%ZTYPE["TRM" Q 43 S %X=$F(IO("P"),"M") I %X S %A=+$E(IO("P"),%X,99),$P(%Z91,"^")=$S(%A>255:255,1:%A) 44 S %X=$F(IO("P"),"L") I %X S $P(%Z91,"^",3)=+$E(IO("P"),%X,99) 45 Q:%A>3!(%ZTYPE'["TRM") 46 ASKMAR I %IS["M",'$D(IOP),$S(%E=%H:+$P(%Z,"^",3),1:1),$P(%Z,"^",4) W " Right Margin: " W:$P(%Z91,"^")]"" +%Z91,"// " 47 E Q 48 D SBR^%ZIS1 I '$D(DTOUT)&'$D(DUOUT) S:%X=""&($P(%Z91,"^")]"") %X=+%Z91 G ASKMAR:%X'?1.N S $P(%Z91,"^")=$S(%X>255:255,1:%X) Q 49 S POP=1 I %ZISB&(%ZTYPE["TRM")&(IO'=IO(0)) C IO K IO(1,IO) Q 50 Q 51 SETPAR S:$L(%ZISOPAR)&($E(%ZISOPAR)'="(") %ZISOPAR="("_%ZISOPAR_")" 52 Q 53 AQUE ;Ask about Queueing 54 W ! S %=$S($D(IO("Q")):1,1:2),U="^",%ZISDTIM=60 55 I $D(IO("Q")) W !,"Previously, you have selected queueing." 56 W !,"Do you "_$S($D(IO("Q")):"STILL ",1:"")_"want your output QUEUED" 57 D YN^%ZIS1 K %ZISDTIM G AQUE:%=0 Q:$D(IO("Q")) 58 I %=-1 S POP=1,%ZISHPOP=1,%ZISUOUT=1 C IO K IO(1,IO) Q 59 I %=1 S IO("Q")=1 C IO K IO(1,IO) Q 60 ;I %=2 K IO("Q") 61 Q 62 ST(%ZISTP) ; 63 S %ZISIOST(0)=%A,%ZISIOST=$P($G(^%ZIS(2,%A,0)),"^") 64 S:'$D(%Z91) %Z91=$P($G(^%ZIS(2,%A,1),"132^#^60^$C(8)"),"^",1,4),$P(%Z91,"^",5)=$G(^("XY")) 65 Q:%ZISTP 66 STP N %B ;%E is a pointer to the Device file 67 S %B=$G(^%ZIS(1,%E,91)) 68 S:$P(%B,"^")]"" $P(%Z91,"^")=+%B S:$P(%B,"^",3)]"" $P(%Z91,"^",3)=$P(%B,"^",3) ;S $P(%Z91,"^",5)=$G(^%ZIS(2,%ZISIOST(0),"XY")) 69 Q 70 SUBIEN(%1,%) ;Return Subtype ien. %1 is call by Ref. 71 N %XX,%YY 72 I $D(^%ZIS(2,"B",%1))>9 S %1=+$O(^%ZIS(2,"B",%1,0)) Q 73 I '$G(%) S X="" Q 74 S %XX=%1 D 2^%ZIS5 S %1=+%YY 75 Q 76 SUBTYPE(%A) ;Called from %ZISH 77 N %ZISIOST,%Z91 78 S:$G(%A)="" %A="P-OTHER" 79 D SUBIEN(.%A),ST(1) 80 S IOM=$P(%Z91,U,1),IOF=$P(%Z91,U,2),IOSL=$P(%Z91,U,3),IOST=%ZISIOST,IOST(0)=%ZISIOST(0),IOBS="$C(8)" 81 S:IOST="" IOST="P-OTHER",IOST(0)=0 82 Q 1 %ZIS3 ;SFISC/AC,RWF -- DEVICE HANDLER(DEVICE TYPES & PARAMETERS) ;10/06/2005 13:23 2 ;;8.0;KERNEL;**18,36,69,104,391**;JUL 10, 1995 3 I %ZIS'["T",$G(^%ZIS(1,+%E,"POX"))]"" D XPOX^ZISX(%E) 4 I $D(%ZISQUIT) S POP=1 K %ZISQUIT 5 S %ZISCHK=1 6 I 'POP&(%ZISB)&(%ZTYPE'="RES")&(%ZTYPE'="OTH")&(%ZTYPE'="SDP")&(IO'["::") D DEVOK 7 G Q:POP 8 G @%ZTYPE:(%ZTYPE["TRM"),@(%ZTYPE_"^%ZIS6") ;Jump to next part 9 ; 10 Q I $D(%ZISUOUT) K %ZISUOUT,%ZISHP,%ZISHPOP Q 11 I $D(%ZISHPOP)&$S(IO="":1,1:'$D(IO(1,IO))) D HGBSY^%ZIS2 Q 12 I POP S:%IS'["T" IO="" I $D(%ZISHG(0)),%IS'["D",'$D(%ZISHPOP) G HUNT^%ZIS2 13 Q 14 VTRM ;Virtual terminal type 15 TRM D OPEN^%ZIS4:'POP&(%ZISB&(%IS'["T")),MARGN:'POP,SETPAR:'POP ;Terminal type 16 I 'POP,%IS'["T",%ZISB=1,'$D(IOP),IO'=IO(0),'$D(IO("Q")),%IS["Q" D AQUE 17 W:'$D(IOP) ! I '$D(IO("Q")) D O^%ZIS4:'POP&(%ZISB&(%IS'["T")) 18 G Q 19 DEVOK N X,Y,X1 20 S X=IO,X1=%ZTYPE 21 D DEVOK^%ZOSV I Y=-99!(Y=0)!(Y=$J) Q 22 I Y>0 S POP=1 W:'$D(IOP)&('$D(%ZISHG(0))!(%IS["D")) !,*7,"[Device Unavailable]" Q 23 I Y=-1 S IO="",POP=1 W:'$D(IOP)&('$D(ZISHG(0))!(%IS["D")) !,*7,"[Device does not Exist or Unavailable]" Q 24 Q 25 ; 26 MARGN ;Get the margin and page length 27 S %A=$P(%Y,";",1) 28 I %A?1A.ANP D SUBIEN(.%A,1) I $D(^%ZIS(2,%A,1)) K %Z91 D ST(1) S %Y=$P(%Y,";",2,9),%ZISMY=$P(%ZISMY,";",2,9) G MARGN 29 I %A>3 S $P(%Z91,"^")=$S(%A>255:255,1:+%A) 30 I $P(%Y,";",2) S $P(%Z91,"^",3)=+$S($P(%Y,";",2)>65530:65530,1:$P(%Y,";",2)) ;Cache fix for $Y#65535 wrap 31 ; 32 ALTP I '$D(IO("P")) Q:%A>3 G ASKMAR:%ZTYPE["TRM" Q 33 S %X=$F(IO("P"),"M") I %X S %A=+$E(IO("P"),%X,99),$P(%Z91,"^")=$S(%A>255:255,1:%A) 34 S %X=$F(IO("P"),"L") I %X S $P(%Z91,"^",3)=+$E(IO("P"),%X,99) 35 Q:%A>3!(%ZTYPE'["TRM") 36 ASKMAR I %IS["M",'$D(IOP),$S(%E=%H:+$P(%Z,"^",3),1:1),$P(%Z,"^",4) W " Right Margin: " W:$P(%Z91,"^")]"" +%Z91,"// " 37 E Q 38 D SBR^%ZIS1 I '$D(DTOUT)&'$D(DUOUT) S:%X=""&($P(%Z91,"^")]"") %X=+%Z91 G ASKMAR:%X'?1.N S $P(%Z91,"^")=$S(%X>255:255,1:%X) Q 39 S POP=1 I %ZISB&(%ZTYPE["TRM")&(IO'=IO(0)) C IO K IO(1,IO) Q 40 Q 41 SETPAR S:%ZISOPAR]""&($A(%ZISOPAR)-40) %ZISOPAR="("_%ZISOPAR_")" 42 Q 43 AQUE W ! S %=$S($D(IO("Q")):1,1:2),U="^",%ZISDTIM=60 44 I $D(IO("Q")) W !,"Previously, you have selected queueing." 45 W !,"Do you "_$S($D(IO("Q")):"STILL ",1:"")_"want your output QUEUED" 46 D YN^%ZIS1 K %ZISDTIM G AQUE:%=0 Q:$D(IO("Q")) 47 I %=-1 S POP=1,%ZISHPOP=1,%ZISUOUT=1 C IO K IO(1,IO) Q 48 I %=1 S IO("Q")=1 C IO K IO(1,IO) Q 49 Q 50 ST(%ZISTP) ; 51 S %ZISIOST(0)=%A,%ZISIOST=$P($G(^%ZIS(2,%A,0)),"^") 52 S:'$D(%Z91) %Z91=$P($G(^%ZIS(2,%A,1),"132^#^60^$C(8)"),"^",1,4),$P(%Z91,"^",5)=$G(^("XY")) 53 Q:%ZISTP 54 STP N %B ;%E is a pointer to the Device file 55 S %B=$G(^%ZIS(1,%E,91)) 56 S:$P(%B,"^")]"" $P(%Z91,"^")=+%B S:$P(%B,"^",3)]"" $P(%Z91,"^",3)=$P(%B,"^",3) ;S $P(%Z91,"^",5)=$G(^%ZIS(2,%ZISIOST(0),"XY")) 57 Q 58 SUBIEN(%1,%) ;Return Subtype ien. %1 is call by Ref. 59 N %XX,%YY 60 I $D(^%ZIS(2,"B",%1))>9 S %1=+$O(^%ZIS(2,"B",%1,0)) Q 61 I '$G(%) S X="" Q 62 S %XX=%1 D 2^%ZIS5 S %1=+%YY 63 Q 64 SUBTYPE(%A) ;Called from %ZISH 65 N %ZISIOST,%Z91 66 S:$G(%A)="" %A="P-OTHER" 67 D SUBIEN(.%A),ST(1) 68 S IOM=$P(%Z91,U,1),IOF=$P(%Z91,U,2),IOSL=$P(%Z91,U,3),IOST=%ZISIOST,IOST(0)=%ZISIOST(0),IOBS="$C(8)" 69 S:IOST="" IOST="P-OTHER",IOST(0)=0 70 Q 71 -
WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZIS4.m
r613 r623 1 %ZIS4 ;ISF/RWF,DW - DEVICE HANDLER SPECIFIC CODE (GT.M for Unix/VMS) ;1/24/08 16:08 2 ;;8.0;KERNEL;**275,425,440**;Jul 10, 1995;Build 13 3 ;Per VHA Directive 2004-038, this routine should not be modified 4 OPEN ;From %ZIS3 for TRM 5 G OPN2:$D(IO(1,IO)) 6 S POP=0 D OP1 G NOPEN:'$D(IO(1,IO)) 7 OPN2 ; 8 I $D(%ZISHP),'$D(IOP) W !,*7," Routing to device "_$P(^%ZIS(1,%E,0),"^",1)_$S($D(^(1)):" "_$P(^(1),"^",1)_" ",1:"") 9 Q 10 NOPEN I %IS'["D",$D(%ZISHP)!(%ZISHG]"") S POP=1 Q 11 I '$D(IOP) W *7," [BUSY]" W " ... RETRY" S %=2,U="^" D YN^%ZIS1 G OPEN:%=1 12 S POP=1 Q 13 Q 14 ;Why no open paraneters??? 15 OP1 N $ET S $ET="G OPNERR^%ZIS4" 16 I $D(%ZISLOCK) L +@%ZISLOCK:5 E S POP=1 Q 17 O IO::%ZISTO S:$T IO(1,IO)="" S:'$T POP=1 18 Q 19 OPNERR ;Open Error 20 S POP=1,IO("LASTERR")=$G(IO("ERROR")),IO("ERROR")=$$EC^%ZOSV,$EC="" 21 Q 22 ; 23 O ;From %ZIS6 for all types. 24 D:%IS["L" ZIO 25 I $D(IO("S")),$D(^%ZIS(2,IO("S"),10)),^(10)]"" U IO(0) D X10^ZISX ;Open Printer Port 26 OPAR I $D(IOP),%ZTYPE="HFS",$D(%IS("HFSIO")),$D(%IS("IOPAR")),%IS("HFSIO")]"" S IO=%IS("HFSIO"),%ZISOPAR=%IS("IOPAR") 27 I %ZTYPE="CHAN" D TCPIP Q:POP G OXECUTE^%ZIS6 28 S %A=%ZISOPAR_$S(%ZISOPAR["):":"",1:":"_%ZISTO) 29 N % S %(IO)="",%=$P($P($NA(%(IO)),"(",2),")") 30 S %A=%_$E(":",%A]"")_%A 31 D O1 I POP D Q 32 .I %ZTYPE="HFS",'$D(IOP),$G(IO("ERROR"))["file not found" W !,?5,*7,"[File Not Found]" Q 33 .W:'$D(IOP) !,?5,*7,"[DEVICE IS BUSY]" Q 34 ;S IO(1,IO)="" U IO S:'(IO=IO(0)&'$D(IO("S"))&'$D(ZTQUEUED)) $X=0,$Y=0 I %ZTYPE["TRM" U IO:(WIDTH=+%Z91) 35 U IO S $X=0,$Y=0 I %ZTYPE["TRM" U IO:(WIDTH=+%Z91) 36 I %ZISUPAR]"" S %A1=""""_IO_""":"_%ZISUPAR U @%A1 37 ;U:%IS'[0 IO(0) 38 G OXECUTE^%ZIS6 39 ; 40 O1 N $ES,$ET S $ET="G OPNERR^%ZIS4" 41 I $D(%ZISLOCK) L +@%ZISLOCK:5 E S POP=1 Q 42 O @%A S:'$T&(%A?.E1":".N) POP=1 S:'POP IO(1,IO)="" 43 S IO("ERROR")="" Q 44 ; 45 ;Need to find out how to get IP address 46 ZIO N %,%1 S (%,%1)=$ZIO 47 I $ZV["VMS",%["_TNA" D 48 . S (%,%1)=$ZGETDVI($I,"TT_ACCPORNAM") 49 . S %=$S(%["Host:":$P($P(%,"Host: ",2)," ")_":"_$P(%,"Port: ",2),1:%) S:%[" " %=$TR(%," ") 50 I $ZV'["VMS" D 51 . S (%,%1)=$ZTRNLNM("REMOTEHOST") S:$L(%) %1="Host:"_% S:'$L(%) %=$ZIO 52 S IO("ZIO")=% S:(%1["Host:")&'$D(IO("IP")) IO("IP")=$P(%,":") 53 Q 54 ; 55 TCPIP ;For TCP/IP devices, should use ^%ZISTCP 56 N %S 57 S %ZISTO=$G(%ZISTO,3) 58 S %A="IO:"_$S($E(%ZISOPAR)="(":"",1:"(")_%ZISOPAR_$S($E(%ZISOPAR,$L(%ZISOPAR))=")":"",1:")")_":%ZISTO:""SOCKET""" 59 ;U $P W !,"%A=",%A 60 O @%A I '$T S POP=1 Q ;D O1 ;Do the open. 61 U IO:(WIDTH=512:NOWRAP:EXCEPT="G OPNERR^%ZIS4") S %S=$KEY 62 U $P ;W !,"$KEY=",%S 63 Q 64 ; 65 SPOOL ;%ZDA=pointer to ^XMB(3.51, %ZFN=spool file name. 66 I $D(ZISDA) W:'$D(IOP) !?5,*7,"You may not Spool the printing of a Spool document" G N 67 I $D(DUZ)[0 W:'$D(IOP) !,"Must be a valid user." G N 68 R S %ZY=-1 D NEWDOC^ZISPL1 G N:%ZY'>0 69 S %ZDA=+%ZY,%ZFN=$P(%ZY(0),U,2),IO("DOC")=$P(%ZY(0),U,1) G OK:$D(IO("Q")) 70 G:'%ZISB OK I '$P(%ZY,"^",3),$L(%ZFN) O %ZFN:(append:nowrap):2 G DOC 71 S %ZFN=IO_"SPOOL_no_"_%ZDA_".TMP" D SPL2 G:%ZFN']"" N S $P(^XMB(3.51,%ZDA,0),U,2)=%ZFN,^XMB(3.51,"C",%ZFN,%ZDA)="" 72 DOC S IO=%ZFN,IO("SPOOL")=%ZDA,^XUTL("XQ",$J,"SPOOL")=%ZDA,IOF="#" 73 I $D(^%ZIS(1,%ZISIOS,1)),$P(^(1),"^",8),$O(^("SPL",0)) S ^XUTL("XQ",$J,"ADSPL")=%ZISIOS,ZISPLAD=%ZISIOS 74 OK K %ZDA,%ZFN Q 75 N K %ZDA,%ZFN,IO("DOC") S POP=1 Q 76 ; 77 SPL2 ;Open for write 78 O %ZFN:(newversion:noreadonly:nowrap:exception="G SPL4"):2 G:$ZA<0 SPL4 S IO(1,%ZFN)="" Q 79 ; 80 SPL3 ;Open for Read 81 O %ZFN:(readonly:exception="G SPL4"):2 S:'$T ZISPLQ=1 G:'$T SPL4 S IO(1,%ZFN)="" Q 82 SPL4 W:'$D(IOP)&'$D(ZTQUEUED) !?5,*7,"Couldn't open the spool file." S %ZFN="" Q 83 ; 84 CLOSE ;Close out the spool 85 N %,%1,%Z1,%ZFN,%ZS,%ZDA,XS,%Y,%X 86 I $L(IO) C IO K IO(1,IO) 87 D FILE^ZISPL1 I %ZDA'>0 K ZISPLAD Q 88 S %ZFN=$P(%ZS,"^",2) D SPL3 Q:%ZFN']"" S %ZCR=$C(13),%Y="" 89 S %Z1=+$G(^XTV(8989.3,1,"SPL")),%=0 90 U %ZFN F R %X#255:5 Q:$ZEOF S %2=%X D CL2 Q:%Z1<% 91 SPLEX C %ZFN:(DELETE) K:%ZFN]"" IO(1,%ZFN) D CLOSE^ZISPL1 K %Y,%X,%1,%ZFN Q 92 ; 93 CL2 S %=%+1 I %Z1<% S ^XMBS(3.519,XS,2,%,0)="*** INCOMPLETE REPORT -- SPOOL DOCUMENT LINE LIMIT EXCEEDED ***",$P(^XMB(3.51,%ZDA,0),"^",11)=1 Q 94 I %2[$C(12) S ^XMBS(3.519,XS,2,%,0)="|TOP|" Q 95 S ^XMBS(3.519,XS,2,%,0)=%2 Q 96 ; 97 HFS G HFS^%ZISF 98 REWMT(IO,IOPAR) ;Rewind Magtape 99 S X="REWERR^%ZIS4",@^%ZOSF("TRAP") 100 U IO W *5 101 Q 1 102 REWSDP(IO,IOPAR) ;Rewind SDP 103 G REW1 104 REWHFS(IO,IOPAR) ;Rewind Host File. 105 REW1 S X="REWERR^%ZIS4",@^%ZOSF("TRAP") 106 U IO:(REWIND) 107 Q 1 108 REWERR ;Error encountered 109 Q 0 1 %ZIS4 ;ISF/RWF,DW - DEVICE HANDLER SPECIFIC CODE (GT.M for Unix/VMS) ;03/07/2007 2 ;;8.0;KERNEL;**275,425**;Jul 10, 1995;Build 18 3 ; 4 OPEN ;From %ZIS3 for TRM 5 G OPN2:$D(IO(1,IO)) 6 S POP=0 D OP1 G NOPEN:'$D(IO(1,IO)) 7 OPN2 ; 8 I $D(%ZISHP),'$D(IOP) W !,*7," Routing to device "_$P(^%ZIS(1,%E,0),"^",1)_$S($D(^(1)):" "_$P(^(1),"^",1)_" ",1:"") 9 Q 10 NOPEN I %IS'["D",$D(%ZISHP)!(%ZISHG]"") S POP=1 Q 11 I '$D(IOP) W *7," [BUSY]" W " ... RETRY" S %=2,U="^" D YN^%ZIS1 G OPEN:%=1 12 S POP=1 Q 13 Q 14 ;Why no open paraneters??? 15 OP1 N $ES,$ET S $ET="G OPNERR^%ZIS4" 16 L:$D(%ZISLOCK) +@%ZISLOCK:60 17 O IO::%ZISTO S:$T IO(1,IO)="" S:'$T POP=1 L:$D(%ZISLOCK) -@%ZISLOCK 18 Q 19 OPNERR ;Open Error 20 S POP=1,IO("LASTERR")=$G(IO("ERROR")),IO("ERROR")=$$EC^%ZOSV,$EC="" Q 21 ; 22 O ;From %ZIS6 for other types. 23 D:%IS["L" ZIO 24 LCKGBL ;Lock Global 25 I %ZTYPE="CHAN" N % S %=$G(^%ZIS(1,+%E,"GBL")) I $L(%) L @("+^"_%_":0") S:'$T POP=1 I POP W:'$D(IOP) !,?5,*7,"[DEVICE IS BUSY]" Q 26 I $D(IO("S")),$D(^%ZIS(2,IO("S"),10)),^(10)]"" U IO(0) D X10^ZISX 27 OPAR I $D(IOP),%ZTYPE="HFS",$D(%IS("HFSIO")),$D(%IS("IOPAR")),%IS("HFSIO")]"" S IO=%IS("HFSIO"),%ZISOPAR=%IS("IOPAR") 28 I %ZTYPE="CHAN" D TCPIP Q:POP G OXECUTE^%ZIS6 29 S %A=%ZISOPAR_$S(%ZISOPAR["):":"",%ZTYPE["CHAN"&($P(%ZTIME,"^",3)="n"):"",1:":"_%ZISTO) 30 N % S %(IO)="",%=$P($P($NA(%(IO)),"(",2),")") 31 S %A=%_$E(":",%A]"")_%A 32 D O1 I POP D Q 33 .I %ZTYPE="HFS",'$D(IOP),$G(IO("ERROR"))["file not found" W !,?5,*7,"[File Not Found]" Q 34 .W:'$D(IOP) !,?5,*7,"[DEVICE IS BUSY]" Q 35 ;S IO(1,IO)="" U IO S:'(IO=IO(0)&'$D(IO("S"))&'$D(ZTQUEUED)) $X=0,$Y=0 I %ZTYPE["TRM" U IO:(WIDTH=+%Z91) 36 U IO S $X=0,$Y=0 I %ZTYPE["TRM" U IO:(WIDTH=+%Z91) 37 I %ZISUPAR]"" S %A1=""""_IO_""":"_%ZISUPAR U @%A1 38 ;U:%IS'[0 IO(0) 39 G OXECUTE^%ZIS6 40 ; 41 O1 N $ES,$ET S $ET="G OPNERR^%ZIS4" 42 L:$D(%ZISLOCK) +@%ZISLOCK:60 43 O @%A S:'$T&(%A?.E1":".N) POP=1 S:'POP IO(1,IO)="" L:$D(%ZISLOCK) -@%ZISLOCK 44 S IO("ERROR")="" Q 45 ; 46 ;Need to find out how to get IP address 47 ZIO N %,%1 S (%,%1)=$ZIO 48 I $ZV["VMS",%["_TNA" D 49 . S (%,%1)=$ZGETDVI($I,"TT_ACCPORNAM") 50 . S %=$S(%["Host:":$P($P(%,"Host: ",2)," ")_":"_$P(%,"Port: ",2),1:%) S:%[" " %=$TR(%," ") 51 I $ZV'["VMS" D 52 . S (%,%1)=$ZTRNLNM("REMOTEHOST") S:$L(%) %1="Host:"_% S:'$L(%) %=$ZIO 53 S IO("ZIO")=% S:(%1["Host:")&'$D(IO("IP")) IO("IP")=$P(%,":") 54 Q 55 ; 56 TCPIP ;For TCP/IP devices 57 N %S 58 S %ZISTO=$G(%ZISTO,3) 59 S %A="IO:"_$S($E(%ZISOPAR)="(":"",1:"(")_%ZISOPAR_$S($E(%ZISOPAR,$L(%ZISOPAR))=")":"",1:")")_":%ZISTO:""SOCKET""" 60 ;U $P W !,"%A=",%A 61 O @%A I '$T S POP=1 Q ;D O1 ;Do the open. 62 U IO:(WIDTH=512:NOWRAP:EXCEPT="G OPNERR^%ZIS4") S %S=$KEY 63 U $P ;W !,"$KEY=",%S 64 Q 65 ; 66 SPOOL ;%ZDA=pointer to ^XMB(3.51, %ZFN=spool file name. 67 I $D(ZISDA) W:'$D(IOP) !?5,*7,"You may not Spool the printing of a Spool document" G N 68 I $D(DUZ)[0 W:'$D(IOP) !,"Must be a valid user." G N 69 R S %ZY=-1 D NEWDOC^ZISPL1 G N:%ZY'>0 S %ZDA=+%ZY,%ZFN=$P(%ZY(0),U,2),IO("DOC")=$P(%ZY(0),U,1) G OK:$D(IO("Q")) 70 G:'%ZISB OK I '$P(%ZY,"^",3),%ZFN]"" D SPL3 G N:%ZFN']"",DOC 71 S %ZFN=IO_"SPOOL_no_"_%ZDA_".TMP" D SPL2 G:%ZFN']"" N S $P(^XMB(3.51,%ZDA,0),U,2)=%ZFN,^XMB(3.51,"C",%ZFN,%ZDA)="" 72 DOC S IO=%ZFN,IO("SPOOL")=%ZDA,^XUTL("XQ",$J,"SPOOL")=%ZDA,IOF="#" 73 I $D(^%ZIS(1,%ZISIOS,1)),$P(^(1),"^",8),$O(^("SPL",0)) S ^XUTL("XQ",$J,"ADSPL")=%ZISIOS,ZISPLAD=%ZISIOS 74 OK K %ZDA,%ZFN Q 75 N K %ZDA,%ZFN,IO("DOC") S POP=1 Q 76 SPL2 O %ZFN:(NEWVERSION:WORLD=RWD) G:$ZA<0 SPL4 S IO(1,%ZFN)="" Q 77 SPL3 N X S X="SPL4^%ZIS4",@^%ZOSF("TRAP") 78 O %ZFN:READONLY:1 S:'$T ZISPLQ=1 G:$ZA<0!('$T) SPL4 S IO(1,%ZFN)="" Q 79 SPL4 W:'$D(IOP)&'$D(ZTQUEUED) !?5,*7,"Couldn't open the spool file." S %ZFN="" Q 80 CLOSE N %Z1 C:IO]"" IO K:IO]"" IO(1,IO) D FILE^ZISPL1 I %ZDA'>0 K ZISPLAD Q 81 S %ZFN=$P(%ZS,"^",2) D SPL3 Q:%ZFN']"" U %ZFN S %ZCR=$C(13),%Y="",X="SPLEOF^%ZIS4",@^%ZOSF("TRAP") 82 S %Z1=+$G(^XTV(8989.3,1,"SPL")) 83 F %=0:0 R %X#255:5 Q:$ZA<0 S %2=%X D CL2 G:%Z1<% SPLEX 84 SPLEOF I $ZE'["ENDO" Q ;Send error up 85 SPLEX C %ZFN:(DELETE) K:%ZFN]"" IO(1,%ZFN) D CLOSE^ZISPL1 K %Y,%X,%1,%ZFN Q 86 ; 87 CL2 S %=%+1 I %Z1<% S ^XMBS(3.519,XS,2,%,0)="*** INCOMPLETE REPORT -- SPOOL DOCUMENT LINE LIMIT EXCEEDED ***",$P(^XMB(3.51,%ZDA,0),"^",11)=1 Q 88 I %2[$C(12) S ^XMBS(3.519,XS,2,%,0)="|TOP|" Q 89 S ^XMBS(3.519,XS,2,%,0)=%2 Q 90 ; 91 HFS G HFS^%ZISF 92 REWMT(IO,IOPAR) ;Rewind Magtape 93 S X="REWERR^%ZIS4",@^%ZOSF("TRAP") 94 U IO W *5 95 Q 1 96 REWSDP(IO,IOPAR) ;Rewind SDP 97 G REW1 98 REWHFS(IO,IOPAR) ;Rewind Host File. 99 REW1 S X="REWERR^%ZIS4",@^%ZOSF("TRAP") 100 U IO:(REWIND) 101 Q 1 102 REWERR ;Error encountered 103 Q 0 -
WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZIS6.m
r613 r623 1 %ZIS6 ;SFISC/AC - DEVICE HANDLER -- RESOURCES ;1/24/08 16:09 2 ;;8.0;KERNEL;**24,49,69,118,127,136,440**;JUL 10, 1995;Build 13 3 ;Per VHA Directive 2004-038, this routine should not be modified 4 ;Expect that IO is current device 5 OXECUTE ;Open Execute 6 I $D(^%ZIS(2,%ZISIOST(0),2))=1 S %Y=^(2) D 2 7 ANSBAK ;Answer Back 8 I $D(^%ZIS(2,%ZISIOST(0),102)) S %Y=^(102) D 2 E S POP=1 D:'$D(IOP) SAY($C(7)_"[NOT ON LINE]") C:%ZISB IO K IO(1,IO) G QUIT 9 I $D(%ZISMTR) X ^%ZOSF("MAGTAPE") U IO W:$D(%MT("REW")) @%MT("REW") U IO(0) K %MT 10 G QUIT:'$D(IO("P")) 11 I $F(IO("P"),"B"),$D(^%ZIS(2,%ZISIOST(0),7)) S %Y=$P(^(7),"^",1) I %Y]"" W @%Y 12 S %Y=$F(IO("P"),"P") G QLTY:'%Y S %Y=+$E(IO("P"),%Y,99),%X=$S(%Y=16:12.1,%Y=10!(%Y=12):5,1:"") G QLTY:'%X 13 S %Y=$S($D(^%ZIS(2,%ZISIOST(0),%X)):$P(^(%X),"^",$S(%Y=12:2,1:1)),1:"") 14 I %Y]"" W @%Y 15 QLTY S %Y=$F(IO("P"),"Q") Q:'%Y S %Y=+$E(IO("P"),%Y,99),%X=$S(%Y<0!(%Y>2):0,1:%Y+1) 16 I %X S %Y=$S($D(^%ZIS(2,%ZISIOST(0),12.2)):$P(^(12.2),"^",%X),1:"") I %Y]"" W @%Y 17 QUIT U:%IS'[0 IO(0) 18 Q 19 2 Q:%Y="" I %IS'[0,$D(^%ZIS(1,+%H,"TYPE")),^("TYPE")["TRM" D OH Q:POP 20 S %X=$T U IO D %Y^ZISX ;Q:'%X U IO(0) 21 Q 22 OH Q:$S($G(IO(0))]"":$D(IO(1,IO(0))),1:0) 23 N X S X="OPNERR^%ZIS4",@^%ZOSF("TRAP") 24 O IO(0)::0 S IO(1,IO(0))="" Q ;See that HOME DEVICE is open. 25 ; 26 SAY(%SAY) ; 27 Q:%IS[0 U IO(0) W %SAY U IO 28 Q 29 RES1 ;Allocate a resource slot, Release in %ZISC. 30 N A,L,X,%ZISD0 31 S %ZISD0=$O(^%ZISL(3.54,"B",IO,0)) 32 I '%ZISD0 S %ZISD0=$$RADD(IO) ;New one 33 L +^%ZISL(3.54,%ZISD0,0):2 I '$T S POP=1 W:'$D(IOP) *7," [NOT Available]" G RESX 34 RES2 S X=$P(^%ZISL(3.54,%ZISD0,0),"^",2) 35 I X<1 S POP=1 W:'$D(IOP) *7," [NOT Available]" G RESX 36 S X=$S(X>0:X-1,1:0),$P(^%ZISL(3.54,%ZISD0,0),"^",2)=X 37 ; 38 R1 ;Grab a slot 39 S IO(1,IO)="RES",A=$G(^%ZISL(3.54,%ZISD0,1,0),"^3.542^^") 40 F L=1:1:%ZISRL I '$D(^%ZISL(3.54,%ZISD0,1,L,0)) Q 41 I '$T K IO(1,IO) G RES2 ;No free slots 42 S ^%ZISL(3.54,%ZISD0,1,L,0)=L_"^"_%ZISV_"^"_$J_"^"_$G(ZTSK)_"^"_$H,^%ZISL(3.54,"AJ",$J,%ZISD0,L)="",^%ZISL(3.54,%ZISD0,1,"B",L,L)="" 43 S $P(A,"^",3,4)=L_U_($P(A,U,4)+1),^%ZISL(3.54,%ZISD0,1,0)=A 44 RESX L -^%ZISL(3.54,%ZISD0,0) Q 45 ; 46 RADD(X) ;Add Resource 47 N %1,%2 48 S %1=$G(^%ZISL(3.54,0),"RESOURCE^3.54^^"),%2=$P(%1,U,3) 49 F %2=%2:1 Q:'$D(^%ZISL(3.54,%2,0)) 50 S $P(^%ZISL(3.54,0),U,3,4)=%2_U_($P(%1,U,4)+1),^%ZISL(3.54,%2,0)=X_"^"_$G(%ZISRL,1),^%ZISL(3.54,"B",X,%2)="" 51 Q %2 52 ; 53 RESOK ;DEVOK check for RES devices, for all OS's. 54 N %ZISD0,%ZISD1 55 S Y=0,%ZISD0=$O(^%ZISL(3.54,"B",X,0)) 56 I '%ZISD0 S Y=-1,%ZISD0=$O(^%ZIS(1,"C",X,0)) Q:'%ZISD0 Q:'$D(^%ZIS(1,+%ZISD0,0)) Q:$P(^(0),"^")'=X Q:'$D(^("TYPE")) Q:^("TYPE")'="RES" S Y=0 Q 57 S X1=$G(^%ZISL(3.54,+%ZISD0,0)) 58 I $P(X1,"^",2)&(X=$P(X1,"^")) S Y=0 Q 59 S Y=999 F %ZISD1=0:0 S %ZISD1=$O(^%ZISL(3.54,%ZISD0,1,%ZISD1)) Q:%ZISD1'>0 I $D(^(%ZISD1,0)) S Y=$P(^(0),"^",3) Q 60 Q 61 ; 62 Q G Q^%ZIS3 63 HG ; 64 Q 65 SPL ;Spool type 66 N %E,%Z D MARGN^%ZIS3 W:'$D(IOP) ! D SPOOL^%ZIS4:%IS'["T" 67 G Q 68 MT D MARGN^%ZIS3,ASKPAR,AMTREW:'POP&'$D(IOP)&%ZISB W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T")) ;Magtape type 69 G Q 70 SDP ;Sequential disk processor type 71 D MARGN^%ZIS3,ASKPAR W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T")) 72 G Q 73 HFS ;Host File Server type 74 D MARGN^%ZIS3,HFS^%ZIS4 W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T")) 75 G Q 76 RES ;Resources 77 G Q:%IS["T" N X,X1 I %IS'["R"!'$D(IOP) S POP=1 W:'$D(IOP) *7," [NOT AVAILABLE]" Q 78 G Q:$D(IO(1,IO)) I %IS["T" S X=IO,X1="RES" D DEVOK^%ZIS3 S:Y POP=1 G Q:POP 79 D:%ZISB RES1 G Q 80 CHAN ;Network Channel type devices -- DecNet or TCP/IP devices. 81 I IO="SYS$NET",$I="SYS$INPUT:;" S IO(0)=IO U IO ;DECNET Server Device 82 D MARGN^%ZIS3:'POP,ASKPAR:'POP W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T")) 83 G Q 84 IMPC ;Imaging Work Station 85 BAR ;Bar Code 86 OTH ;Other Device type 87 D MARGN^%ZIS3:'POP,ASKPAR:'POP W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T")) 88 G Q 89 ; 90 ASKPAR ;Ask Parameters 91 G SETPAR^%ZIS3:$D(IOP),SETPAR^%ZIS3:'$P(^%ZIS(1,%E,0),"^",4) W " ADDRESS/PARAMETERS: " W:%ZISOPAR]"" %ZISOPAR_"// " D SBR^%ZIS1 D MSG1:%X="?" G ASKPAR:%X="?" S:%X]"" %ZISOPAR=%X I $D(DTOUT)!$D(DUOUT) S POP=1 92 I POP,%ZISB&(%ZTYPE["TRM") C IO K IO(1,IO) Q 93 Q:POP G SETPAR^%ZIS3 94 ; 95 AMTREW ;Mag Tape Rewind 96 I %ZISB,%ZTYPE="MT",'$D(IOP) W " REWIND" S %=2,U="^",%ZISDTIM=60 D YN^%ZIS1 K %ZISDTIM G AMTREW:%=0 I %=-1 S POP=1 Q 97 S:%=1 %ZISMTR=1 98 Q 99 MSG1 W !?5,"Enter the desired parameters needed to open the selected device.",!?25 100 Q 101 ; 1 %ZIS6 ;SFISC/AC - DEVICE HANDLER -- RESOURCES ;02/04/2000 08:14 2 ;;8.0;KERNEL;**24,49,69,118,127,136**;JUL 10, 1995 3 ;Expect that IO is current device 4 OXECUTE I $D(^%ZIS(2,%ZISIOST(0),2))=1 S %Y=^(2) D 2 5 ANSBAK I $D(^%ZIS(2,%ZISIOST(0),102)) S %Y=^(102) D 2 E S POP=1 D:'$D(IOP) SAY($C(7)_"[NOT ON LINE]") C:%ZISB IO K IO(1,IO) G QUIT 6 I $D(%ZISMTR) X ^%ZOSF("MAGTAPE") U IO W:$D(%MT("REW")) @%MT("REW") U IO(0) K %MT 7 G QUIT:'$D(IO("P")) 8 I $F(IO("P"),"B"),$D(^%ZIS(2,%ZISIOST(0),7)) S %Y=$P(^(7),"^",1) I %Y]"" W @%Y 9 S %Y=$F(IO("P"),"P") G QLTY:'%Y S %Y=+$E(IO("P"),%Y,99),%X=$S(%Y=16:12.1,%Y=10!(%Y=12):5,1:"") G QLTY:'%X 10 S %Y=$S($D(^%ZIS(2,%ZISIOST(0),%X)):$P(^(%X),"^",$S(%Y=12:2,1:1)),1:"") 11 I %Y]"" W @%Y 12 QLTY S %Y=$F(IO("P"),"Q") Q:'%Y S %Y=+$E(IO("P"),%Y,99),%X=$S(%Y<0!(%Y>2):0,1:%Y+1) 13 I %X S %Y=$S($D(^%ZIS(2,%ZISIOST(0),12.2)):$P(^(12.2),"^",%X),1:"") I %Y]"" W @%Y 14 QUIT U:%IS'[0 IO(0) 15 Q 16 2 Q:%Y="" I %IS'[0,$D(^%ZIS(1,+%H,"TYPE")),^("TYPE")["TRM" D OH Q:POP 17 S %X=$T U IO D %Y^ZISX ;Q:'%X U IO(0) 18 Q 19 OH Q:$S($G(IO(0))]"":$D(IO(1,IO(0))),1:0) 20 N X S X="OPNERR^%ZIS4",@^%ZOSF("TRAP") 21 O IO(0)::0 S IO(1,IO(0))="" Q ;See that HOME DEVICE is open. 22 ; 23 SAY(%SAY) ; 24 Q:%IS[0 U IO(0) W %SAY U IO 25 Q 26 RES1 ;Allocate a resource slot, Release in %ZISC. 27 N A,L,X,%ZISD0 28 S %ZISD0=$O(^%ZISL(3.54,"B",IO,0)) 29 I '%ZISD0 S %ZISD0=$$RADD(IO) ;New one 30 L +^%ZISL(3.54,%ZISD0,0):2 I '$T S POP=1 W:'$D(IOP) *7," [NOT Available]" G RESX 31 RES2 S X=$P(^%ZISL(3.54,%ZISD0,0),"^",2) 32 I X<1 S POP=1 W:'$D(IOP) *7," [NOT Available]" G RESX 33 S X=$S(X>0:X-1,1:0),$P(^%ZISL(3.54,%ZISD0,0),"^",2)=X 34 ; 35 R1 ;Grab a slot 36 S IO(1,IO)="RES",A=$G(^%ZISL(3.54,%ZISD0,1,0),"^3.542^^") 37 F L=1:1:%ZISRL I '$D(^%ZISL(3.54,%ZISD0,1,L,0)) Q 38 I '$T K IO(1,IO) G RES2 ;No free slots 39 S ^%ZISL(3.54,%ZISD0,1,L,0)=L_"^"_%ZISV_"^"_$J_"^"_$G(ZTSK)_"^"_$H,^%ZISL(3.54,"AJ",$J,%ZISD0,L)="",^%ZISL(3.54,%ZISD0,1,"B",L,L)="" 40 S $P(A,"^",3,4)=L_U_($P(A,U,4)+1),^%ZISL(3.54,%ZISD0,1,0)=A 41 RESX L -^%ZISL(3.54,%ZISD0,0) Q 42 ; 43 RADD(X) ;Add Resource 44 N %1,%2 45 S %1=$G(^%ZISL(3.54,0),"RESOURCE^3.54^^"),%2=$P(%1,U,3) 46 F %2=%2:1 Q:'$D(^%ZISL(3.54,%2,0)) 47 S $P(^%ZISL(3.54,0),U,3,4)=%2_U_($P(%1,U,4)+1),^%ZISL(3.54,%2,0)=X_"^"_$G(%ZISRL,1),^%ZISL(3.54,"B",X,%2)="" 48 Q %2 49 ; 50 RESOK ;DEVOK check for RES devices, for all OS's. 51 N %ZISD0,%ZISD1 52 S Y=0,%ZISD0=$O(^%ZISL(3.54,"B",X,0)) 53 I '%ZISD0 S Y=-1,%ZISD0=$O(^%ZIS(1,"C",X,0)) Q:'%ZISD0 Q:'$D(^%ZIS(1,+%ZISD0,0)) Q:$P(^(0),"^")'=X Q:'$D(^("TYPE")) Q:^("TYPE")'="RES" S Y=0 Q 54 S X1=$G(^%ZISL(3.54,+%ZISD0,0)) 55 I $P(X1,"^",2)&(X=$P(X1,"^")) S Y=0 Q 56 S Y=999 F %ZISD1=0:0 S %ZISD1=$O(^%ZISL(3.54,%ZISD0,1,%ZISD1)) Q:%ZISD1'>0 I $D(^(%ZISD1,0)) S Y=$P(^(0),"^",3) Q 57 Q 58 ; 59 Q G Q^%ZIS3 60 HG ; 61 Q 62 SPL N %E,%Z D MARGN^%ZIS3 W:'$D(IOP) ! D SPOOL^%ZIS4:%IS'["T" ;Spool type 63 G Q 64 MT D MARGN^%ZIS3,ASKPAR,AMTREW:'POP&'$D(IOP)&%ZISB W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T")) ;Magtape type 65 G Q 66 SDP D MARGN^%ZIS3,ASKPAR W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T")) ;Sequential disk processor type 67 G Q 68 HFS D MARGN^%ZIS3,HFS^%ZIS4 W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T")) ;Host File Server type 69 G Q 70 RES G Q:%IS["T" N X,X1 I %IS'["R"!'$D(IOP) S POP=1 W:'$D(IOP) *7," [NOT AVAILABLE]" Q ;Resources 71 G Q:$D(IO(1,IO)) I %IS["T" S X=IO,X1="RES" D DEVOK^%ZIS3 S:Y POP=1 G Q:POP 72 D:%ZISB RES1 G Q 73 CHAN ;Network Channel type devices -- DecNet or TCP/IP devices. 74 I IO="SYS$NET",$I="SYS$INPUT:;" S IO(0)=IO U IO ;DECNET Server Device 75 D MARGN^%ZIS3:'POP,ASKPAR:'POP W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T")) 76 G Q 77 IMPC ;Imaging Work Station 78 BAR ;Bar Code 79 OTH D MARGN^%ZIS3:'POP,ASKPAR:'POP W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T")) ;Other Device type 80 G Q 81 ; 82 ASKPAR G SETPAR^%ZIS3:$D(IOP),SETPAR^%ZIS3:'$P(^%ZIS(1,%E,0),"^",4) W " ADDRESS/PARAMETERS: " W:%ZISOPAR]"" %ZISOPAR_"// " D SBR^%ZIS1 D MSG1:%X="?" G ASKPAR:%X="?" S:%X]"" %ZISOPAR=%X I $D(DTOUT)!$D(DUOUT) S POP=1 83 I POP,%ZISB&(%ZTYPE["TRM") C IO K IO(1,IO) Q 84 Q:POP G SETPAR^%ZIS3 85 AMTREW I %ZISB,%ZTYPE="MT",'$D(IOP) W " REWIND" S %=2,U="^",%ZISDTIM=60 D YN^%ZIS1 K %ZISDTIM G AMTREW:%=0 I %=-1 S POP=1 Q 86 S:%=1 %ZISMTR=1 Q 87 MSG1 W !?5,"Enter the desired parameters needed to open the selected device.",!?25 Q 88 ; -
WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZISC.m
r613 r623 1 %ZISC ;SFISC/GFT,AC,MUS - CLOSE LOGIC FOR DEVICES ;1/24/08 16:09 2 ;;8.0;KERNEL;**24,36,49,69,199,216,275,409,440**;JUL 10, 1995;Build 13 3 ;Per VHA Directive 2004-038, this routine should not be modified 4 C0 ; 5 N %,%E,%H,%ZISI,%ZISOS,%ZISX,%ZISV 6 ;Clear IO var we will use for reporting 7 K IO("ERROR"),IO("LASTERR"),IO("CLOSE") 8 ;Protect ourself from calls with incomplete setup. 9 S:$D(IO)[0 IO=$I S:'$D(IO(0)) IO(0)=$P 10 S U="^",%ZISOS=$G(^%ZOSF("OS")),%ZISV=$G(^("VOL")) 11 ;S %=$S(+$G(IOS):IOS,$L($G(ION)):ION,1:IO) 12 S %=$S($L($G(ION)):ION,1:IO) ;p409 13 I (%="")!(IO="") G SETIO:IO(0)]"",END 14 I $G(IOT)="RES" D RES G SETIO ;Handle a resource device 15 ; 16 ;Define subtype info if not already defined. 17 D SUBTYPE 18 ; 19 ;perform close execute 20 I $G(IOST(0))>0 D 21 . I $G(^%ZIS(2,+IOST(0),3))]"",$D(IO(1,IO)) D 22 . . U IO S:$X $X=1 D X3^ZISX:'$D(IO("T")) 23 ; 24 ;Incase the Close execute changed IO, Open IO("HOME") or NULL. 25 I '$L($G(IO)) D Q 26 . S IOP=$S($L($G(IO("HOME"))):"`"_(+IO("HOME")),1:"NULL") D ^%ZIS 27 . Q 28 ; 29 ;Perform the following if the device is open. 30 I $D(IO(1,IO)) D 31 . I $G(IO("P"))["B" D ;Return to normal intensity 32 . . S %=$P($G(^%ZIS(2,+IOST(0),7)),"^",3) I %]"" W @% 33 . I $G(IO("P"))["P" D ;Return to default pitch 34 . . S %=$G(^%ZIS(2,+IOST(0),12.11)) I %]"" W @% 35 . ; 36 . W:$$FF @IOF ;Issue form feed at close 37 . I $$CLOSPP D X11^ZISX:'$D(IO("T")) K IO("S") ;Close printer port 38 . Q 39 ; 40 ;Don't use IOCPU as we now use IO(1,IO) 41 I (IO'=IO(0)!$D(IO("C"))),$D(IO(1,IO)) D 42 . U:$S($D(ZTQUEUED):0,'$L($G(IO(0))):0,$D(IO(1,IO(0)))#2:1,1:0) IO(0) 43 . C IO K IO(1,IO) S IO("CLOSE")=IO ;close device 44 ;Unlock global used to control access. 45 S %=$G(^XUTL("XQ",$J,"lock",+$G(IOS))) I $L(%) L -@% K ^XUTL("XQ",$J,"lock",IOS) 46 ; 47 I $D(IO("SPOOL")) D CLOSE^%ZIS4 ;Special close for spool device 48 ; 49 SETIO ; 50 ;See if old device has PCX code 51 I $G(IOS),$G(^%ZIS(1,+IOS,"PCX"))]"" S %ZISPCX=^("PCX") 52 ;Setup the IO(0) device, should be the home device 53 S IO=IO(0),(IOPAR,IOUPAR)="" K IO("T") D CIOS(IO(0)) 54 I 'IOS S IOT="TRM" G END 55 S ION=$P(^%ZIS(1,IOS,0),"^",1),IOT=$G(^("TYPE")),IOST(0)=$S(IOT["TRM"&($D(^XUTL("XQ",$J,"IOST(0)"))):^("IOST(0)"),1:$G(^%ZIS(1,IOS,"SUBTYPE"))) 56 I IOT["TRM",$D(^XUTL("XQ",$J,"IO")) D HOME^%ZIS G END 57 S %="Y" 58 I IOST(0),$D(^%ZIS(2,IOST(0),1)) S %=^(1),IOM=+%,IOF=$P(%,"^",2),IOSL=$P(%,"^",3),IOBS=$P(%,"^",4) 59 I $D(^%ZIS(1,IOS,91)) S %=^%ZIS(1,IOS,91) S:+% IOM=+% S:$P(%,"^",3) IOSL=$P(%,"^",3) 60 ;Don't know the subtype so set some defaults 61 I %="Y" S IOM=80,IOSL=24,IOF="#",IOST="C-OTHER",IOBS="$C(8)" 62 S1 S:IOST(0) IOST=$P($G(^%ZIS(2,+IOST(0),0)),"^"),IOXY=$G(^("XY")) 63 I '$D(ZTQUEUED),'$D(IO("C")),IOT["TRM" D RM:$D(IO(1,IO)) 64 ;With home device set, Do Post-close execute code of Device closed. 65 END I '$D(IO("T")),$G(%ZISPCX)]"" S %Y=%ZISPCX D %Y^ZISX 66 ;See that any extra IO variables are cleaned up 67 K IO("P"),IO("DOC"),IO("HFSIO"),IO("SPOOL"),IOC,IONOFF 68 ;IOCPU should not be changed. 69 Q 70 ; 71 SUBTYPE ;Find a subtype 72 N %S 73 S IOST=$G(IOST),IOST(0)=+$G(IOST(0)) 74 I $L(IOST)&$L(IOST(0)) Q ;Have a subtype 75 S %S=$G(^%ZIS(2,+IOST(0),0)) I $L(%S) S IOST=$P(%S,U) Q 76 I $L(IOST) S %S=$O(^%ZIS(2,"B",$G(IOST,"X"),0)) I %S>0 S IOST(0)=+%S Q 77 S IOST="",IOST(0)=0 D CIOS($I) Q:IOS'>0 78 S IOST(0)=$G(^%ZIS(1,+IOS,"SUBTYPE")),IOST=$P($G(^%ZIS(2,+IOST(0),0)),"^") 79 Q 80 ; 81 CIOS(%I) ;Find a value for IOS (IEN into device file) 82 N %ZISVT 83 I $D(^XUTL("XQ",$J,"IOS")) S IOS=+^("IOS") Q 84 I $D(%ZISV) S %ZISVT=%I D VTLKUP^%ZIS S IOS=+%E 85 E S IOS=+$O(^%ZIS(1,"C",%I,0)) 86 Q:$G(IOS)>0 87 S %ZISVT=%I D VIRTUAL^%ZIS 88 I $D(%ZISVT) S %H=%E I %ZISVT]"",%H>0,$D(^%ZIS(1,%H,0)),$D(^("TYPE")),^("TYPE")="VTRM" S IOS=%H 89 Q 90 ; 91 RM N X S X=+IOM X ^%ZOSF("RM") 92 Q 93 ; 94 RES ;Close resource device. 95 Q:'$D(IO(1,IO))&'$D(^%ZISL(3.54,"AJ",$J)) 96 N %ZISJOB,%X,%Y,%ZISD0,%ZISD1,%ZISRES,%ZISRL,%ZISY0,%ZTRTN,ZTSAVE,ZTIO 97 S %ZISJOB=$J 98 ; 99 RES1 G RQ:'$D(IOS),RQ:'$D(^%ZIS(1,+IOS,1)) S %ZISRL=+$P(^(1),"^",10),%ZISRL=$S(%ZISRL:%ZISRL,1:1) 100 S %X=$O(^%ZISL(3.54,"B",IO,0)) G RQ:'%X 101 G RQ:'$D(^%ZISL(3.54,+%X,0)) S %ZISD0=+%X,%ZISY0=^(0) 102 S %X=$O(^%ZISL(3.54,"AJ",%ZISJOB,%ZISD0,0)) S %ZISD1=%X G RQ:'%X 103 S %Y=$G(^%ZISL(3.54,%ZISD0,1,+%ZISD1,0)) G RQ:$P(%Y,"^",3)'=%ZISJOB 104 D KILLRES(+%ZISD0,+%ZISD1) 105 RQ K IO(1,IO) 106 Q 107 ; 108 KILLRES(D0,D1) ;Kill one resource use 109 Q:(D0'>0)!(D1'>0) 110 N %X,%Y,%J,%ZISRL 111 L +^%ZISL(3.54,D0,0) 112 S %Y=$G(^%ZISL(3.54,D0,0)) G KRX:%Y="" 113 S %X=$G(^%ZISL(3.54,D0,1,D1,0)),%J=$P(%X,"^",3) S:%J="" %J=" " 114 K ^%ZISL(3.54,D0,1,D1,0),^%ZISL(3.54,D0,1,"B",D1,D1),^%ZISL(3.54,"AJ",%J,D0,D1) 115 S %X=$P(%Y,"^",2)+1,$P(^%ZISL(3.54,D0,0),"^",2)=%X 116 ;I '$D(^%ZISL(3.54,%ZISD0,1,0)) S ^(0)="^3.542A^^" G RQ 117 S %Y=$G(^%ZISL(3.54,D0,1,0)),%X=$P(%Y,"^",4),$P(^%ZISL(3.54,D0,1,0),"^",3,4)="^"_$S(%X>0:(%X-1),1:0) 118 KRX L -^%ZISL(3.54,D0,0) 119 Q 120 ; 121 DQCRES ;Tasked entry point to close resource device. 122 S IO=%ZISRES G RES1 123 ; 124 FF() ;Issue form feed 125 I $E(IOST,1,2)'["C-",$D(IO(1,IO)),$G(IOT)="TRM"!($G(IOT)="SPL"),'$D(IO("T"))&$Y&'$D(IONOFF)&'$D(IO(1,IO,"NOFF")) Q 1 126 Q 0 127 ; 128 CLOSPP() ;Close printer port 129 I $D(IO("S")),$D(^%ZIS(2,+IO("S"),11))&$D(IO(1,IO)) Q 1 130 Q 0 1 %ZISC ;SFISC/GFT,AC,MUS - CLOSE LOGIC FOR DEVICES ;01/14/2002 09:06 2 ;;8.0;KERNEL;**24,36,49,69,199,216,275,409**;JUL 10, 1995;Build 3 3 C0 ; 4 N %,%E,%H,%ZISI,%ZISOS,%ZISX,%ZISV 5 ;Clear IO var we will use for reporting 6 K IO("ERROR"),IO("LASTERR"),IO("CLOSE") 7 ;Protect ourself from calls with incomplete setup. 8 S:$D(IO)[0 IO=$I S:'$D(IO(0)) IO(0)=$P 9 S U="^",%ZISOS=$G(^%ZOSF("OS")),%ZISV=$G(^("VOL")) 10 ;S %=$S(+$G(IOS):IOS,$L($G(ION)):ION,1:IO) 11 S %=$S($L($G(ION)):ION,1:IO) ;p409 12 I (%="")!(IO="") G SETIO:IO(0)]"",END 13 I $G(IOT)="RES" D RES G SETIO ;Handle a resource device 14 ; 15 ;Define subtype info if not already defined. 16 D SUBTYPE 17 ; 18 ;perform close execute 19 I $G(IOST(0))>0 D 20 . I $G(^%ZIS(2,+IOST(0),3))]"",$D(IO(1,IO)) D 21 . . U IO S:$X $X=1 D X3^ZISX:'$D(IO("T")) 22 ; 23 ;Incase the Close execute changed IO, Open IO("HOME") or NULL. 24 I '$L($G(IO)) D Q 25 . S IOP=$S($L($G(IO("HOME"))):"`"_(+IO("HOME")),1:"NULL") D ^%ZIS 26 . Q 27 ; 28 ;Perform the following if the device is open. 29 I $D(IO(1,IO)) D 30 . I $G(IO("P"))["B" D ;Return to normal intensity 31 . . S %=$P($G(^%ZIS(2,+IOST(0),7)),"^",3) I %]"" W @% 32 . I $G(IO("P"))["P" D ;Return to default pitch 33 . . S %=$G(^%ZIS(2,+IOST(0),12.11)) I %]"" W @% 34 . ; 35 . W:$$FF @IOF ;Issue form feed at close 36 . I $$CLOSPP D X11^ZISX:'$D(IO("T")) K IO("S") ;Close printer port 37 . Q 38 ; 39 ;Don't use IOCPU as we now use IO(1,IO) 40 I (IO'=IO(0)!$D(IO("C"))),$D(IO(1,IO)) D 41 . U:$S($D(ZTQUEUED):0,'$L($G(IO(0))):0,$D(IO(1,IO(0)))#2:1,1:0) IO(0) 42 . C IO K IO(1,IO) S IO("CLOSE")=IO ;close device 43 ; 44 ; 45 I $D(IOT),IOT="CHAN",$D(IOS) D 46 .S %=$G(^%ZIS(1,+IOS,"GBL")) 47 .I %]"" L @("-^"_%) ;unlock global used to control access to network channels. 48 I $D(IO("SPOOL")) D CLOSE^%ZIS4 ;Special close for spool device 49 ; 50 SETIO ; 51 ;See if old device has PCX code 52 I $G(IOS),$G(^%ZIS(1,+IOS,"PCX"))]"" S %ZISPCX=^("PCX") 53 ;Setup the IO(0) device, should be the home device 54 S IO=IO(0),(IOPAR,IOUPAR)="" K IO("T") D CIOS(IO(0)) 55 I 'IOS S IOT="TRM" G END 56 S ION=$P(^%ZIS(1,IOS,0),"^",1),IOT=$G(^("TYPE")),IOST(0)=$S(IOT["TRM"&($D(^XUTL("XQ",$J,"IOST(0)"))):^("IOST(0)"),1:$G(^%ZIS(1,IOS,"SUBTYPE"))) 57 I IOT["TRM",$D(^XUTL("XQ",$J,"IO")) D HOME^%ZIS G END 58 S %="Y" 59 I IOST(0),$D(^%ZIS(2,IOST(0),1)) S %=^(1),IOM=+%,IOF=$P(%,"^",2),IOSL=$P(%,"^",3),IOBS=$P(%,"^",4) 60 I $D(^%ZIS(1,IOS,91)) S %=^%ZIS(1,IOS,91) S:+% IOM=+% S:$P(%,"^",3) IOSL=$P(%,"^",3) 61 ;Don't know the subtype so set some defaults 62 I %="Y" S IOM=80,IOSL=24,IOF="#",IOST="C-OTHER",IOBS="$C(8)" 63 S1 S:IOST(0) IOST=$P($G(^%ZIS(2,+IOST(0),0)),"^"),IOXY=$G(^("XY")) 64 I '$D(ZTQUEUED),'$D(IO("C")),IOT["TRM" D RM:$D(IO(1,IO)) 65 ;With home device set, Do Post-close execute code of Device closed. 66 END I '$D(IO("T")),$G(%ZISPCX)]"" S %Y=%ZISPCX D %Y^ZISX 67 ;See that any extra IO variables are cleaned up 68 K IO("P"),IO("DOC"),IO("HFSIO"),IO("SPOOL"),IOC,IONOFF 69 ;IOCPU should not be changed. 70 Q 71 ; 72 SUBTYPE ;Find a subtype 73 N %S 74 S IOST=$G(IOST),IOST(0)=+$G(IOST(0)) 75 I $L(IOST)&$L(IOST(0)) Q ;Have a subtype 76 S %S=$G(^%ZIS(2,+IOST(0),0)) I $L(%S) S IOST=$P(%S,U) Q 77 I $L(IOST) S %S=$O(^%ZIS(2,"B",$G(IOST,"X"),0)) I %S>0 S IOST(0)=+%S Q 78 S IOST="",IOST(0)=0 D CIOS($I) Q:IOS'>0 79 S IOST(0)=$G(^%ZIS(1,+IOS,"SUBTYPE")),IOST=$P($G(^%ZIS(2,+IOST(0),0)),"^") 80 Q 81 ; 82 CIOS(%I) ;Find a value for IOS (IEN into device file) 83 N %ZISVT 84 I $D(^XUTL("XQ",$J,"IOS")) S IOS=+^("IOS") Q 85 I $D(%ZISV) S %ZISVT=%I D VTLKUP^%ZIS S IOS=+%E 86 E S IOS=+$O(^%ZIS(1,"C",%I,0)) 87 Q:$G(IOS)>0 88 S %ZISVT=%I D VIRTUAL^%ZIS 89 I $D(%ZISVT) S %H=%E I %ZISVT]"",%H>0,$D(^%ZIS(1,%H,0)),$D(^("TYPE")),^("TYPE")="VTRM" S IOS=%H 90 Q 91 ; 92 RM N X S X=+IOM X ^%ZOSF("RM") 93 Q 94 ; 95 RES ;Close resource device. 96 Q:'$D(IO(1,IO))&'$D(^%ZISL(3.54,"AJ",$J)) 97 N %ZISJOB,%X,%Y,%ZISD0,%ZISD1,%ZISRES,%ZISRL,%ZISY0,%ZTRTN,ZTSAVE,ZTIO 98 S %ZISJOB=$J 99 ; 100 RES1 G RQ:'$D(IOS),RQ:'$D(^%ZIS(1,+IOS,1)) S %ZISRL=+$P(^(1),"^",10),%ZISRL=$S(%ZISRL:%ZISRL,1:1) 101 S %X=$O(^%ZISL(3.54,"B",IO,0)) G RQ:'%X 102 G RQ:'$D(^%ZISL(3.54,+%X,0)) S %ZISD0=+%X,%ZISY0=^(0) 103 S %X=$O(^%ZISL(3.54,"AJ",%ZISJOB,%ZISD0,0)) S %ZISD1=%X G RQ:'%X 104 S %Y=$G(^%ZISL(3.54,%ZISD0,1,+%ZISD1,0)) G RQ:$P(%Y,"^",3)'=%ZISJOB 105 D KILLRES(+%ZISD0,+%ZISD1) 106 RQ K IO(1,IO) 107 Q 108 ; 109 KILLRES(D0,D1) ;Kill one resource use 110 Q:(D0'>0)!(D1'>0) 111 N %X,%Y,%J,%ZISRL 112 L +^%ZISL(3.54,D0,0) 113 S %Y=$G(^%ZISL(3.54,D0,0)) G KRX:%Y="" 114 S %X=$G(^%ZISL(3.54,D0,1,D1,0)),%J=$P(%X,"^",3) S:%J="" %J=" " 115 K ^%ZISL(3.54,D0,1,D1,0),^%ZISL(3.54,D0,1,"B",D1,D1),^%ZISL(3.54,"AJ",%J,D0,D1) 116 S %X=$P(%Y,"^",2)+1,$P(^%ZISL(3.54,D0,0),"^",2)=%X 117 ;I '$D(^%ZISL(3.54,%ZISD0,1,0)) S ^(0)="^3.542A^^" G RQ 118 S %Y=$G(^%ZISL(3.54,D0,1,0)),%X=$P(%Y,"^",4),$P(^%ZISL(3.54,D0,1,0),"^",3,4)="^"_$S(%X>0:(%X-1),1:0) 119 KRX L -^%ZISL(3.54,D0,0) 120 Q 121 ; 122 DQCRES ;Tasked entry point to close resource device. 123 S IO=%ZISRES G RES1 124 ; 125 FF() ;Issue form feed 126 I $E(IOST,1,2)'["C-",$D(IO(1,IO)),$G(IOT)="TRM"!($G(IOT)="SPL"),'$D(IO("T"))&$Y&'$D(IONOFF)&'$D(IO(1,IO,"NOFF")) Q 1 127 Q 0 128 ; 129 CLOSPP() ;Close printer port 130 I $D(IO("S")),$D(^%ZIS(2,+IO("S"),11))&$D(IO(1,IO)) Q 1 131 Q 0 -
WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZISS1.m
r613 r623 1 %ZISS1 ;AC/SFISC - Collect screen parameters 5/29/88 2:02 PM ;1/24/08 16:10 2 ;;8.0;KERNEL;**69,440**;JUL 10, 1995;Build 13 3 ;Per VHA Directive 2004-038, this routine should not be modified 4 VALID ; 5 N %ZISI,%ZISNP,ZISCH,ZISEND,ZISNUM,ZISQ,ZISXL,ZISXLN ;p440 6 D L 7 Q 8 ; 9 SET2 ; 10 S %ZISFN="" F %ZISZ=0:0 S %ZISFN=$O(%ZISZ(%ZISFN)) Q:%ZISFN="" I $D(%ZISZ(%ZISFN))#2 S %ZISXX=%ZISZ(%ZISFN) D INDCK 11 Q 12 INDCK ; 13 S %ZISY="" 14 I "IOEFLD^IOSTBM"[%ZISFN S @%ZISFN=%ZISXX Q 15 I %ZISXX]"" S @("%ZISY="_%ZISXX) 16 ;E S @("%ZISY="_"""""") 17 I $E(%ZISFN,1,2)="IO" S @%ZISFN=%ZISY 18 E S @("IO"_$E(%ZISFN,1,6))=%ZISY 19 Q:'$D(%ZIS)#2 Q:%ZIS'["I" Q:'$D(%ZISZ(%ZISFN,1)) 20 ; 21 SRAY ; 22 S %=%ZISY,%ZISY=$A($E(%ZISY,1)) 23 F %1=2:1:$L(%) S %ZISY=%ZISY_$S($A(%,%1)<32:$A(%,%1),$A(%,%1)=127:127,1:$E(%,%1)) 24 S IOIS(%ZISY)=%ZISFN 25 Q 26 CHECK ;Entry point called from input transforms of fields in DEV/TT files. 27 N %ZISXX,%ZISYY,%ZISI,%ZISNP,%ZISX1,%ZISX2,ZISCH,ZISNUM,ZISQ,ZISXL,ZISXLN ;p440 28 S %ZISXX=X D L S X=%ZISYY 29 Q 30 CHECK1 ;Entry point called from input transforms of fields in DEV/TT files. 31 N %ZISXX,%ZISYY,%ZISI,%ZISNP,%ZISX1,%ZISX2,ZISCH,ZISNUM,ZISQ,ZISXL,ZISXLN ;p440 32 S %ZISXX=$S(X?1"W ".E:$E(X,3,$L(X)),1:X) 33 D L S X=$S(X?1"W ".E:"W "_%ZISYY,1:%ZISYY) 34 Q 35 FORM ;Entry point called from input transforms of fields in DEV/TT files. 36 Q:$L(X,"_")'>1 37 N %ZISSI,%ZISSY ;p440 38 ;F %ZISSI=1:1:$L(X,"_") S %ZISX1=$P(X,"_",%ZISSI) I %ZISX1]"","#?!"[$E(%ZISX1) S X=$S(%ZISSI=1:"",1:$P(X,"_",1,%ZISSI-1)_",")_%ZISX1_$S(%ZISSI<$L(X,"_"):","_$P(X,"_",%ZISSI+1,255),1:"") W !,%ZISSI_"==>"_X 39 S %ZISSY="" 40 F %ZISSI=1:1:$L(X,"_") S %ZISSY=%ZISSY_$P(X,"_",%ZISSI)_$S($P(X,"_",%ZISSI+1)="":"","#?!"[$E($P(X,"_",%ZISSI+1)):",","#?!"[$E($P(X,"_",%ZISSI)):",",1:"_") 41 S X=%ZISSY 42 Q 43 ; 44 L S ZISQ="""",%ZISNP=0,ZISXLN=$L(%ZISXX) I 'ZISXLN S %ZISYY="" Q 45 S ZISXL=0,%ZISYY="" F %ZISI=0:0 S ZISXL=ZISXL+1 S ZISCH=$E(%ZISXX,ZISXL) D L1 Q:ZISXL'<ZISXLN 46 ;I $L(%ZISYY,"$C(")>2,%ZISYY[")_$C(" S %ZISXX=%ZISYY D L2,L3 S %ZISYY=%ZISXX Q 47 S %ZISXX=%ZISYY D L2,L3 S %ZISYY=%ZISXX 48 Q 49 L1 I ZISCH="_"!(ZISCH=",") S %ZISYY=%ZISYY_"_" Q 50 I ZISCH=ZISQ D QUOTE Q 51 I ZISCH="$" D DOLR Q 52 I ZISCH="*" D STAR Q 53 I ZISCH="(" D PAREN Q 54 S %ZISYY=%ZISYY_ZISCH 55 Q 56 L2 ;Find $C(x)_$C(y) and merge 57 N I ;p440 58 F I=1:1:$L(%ZISXX,"_") S %ZISX1=$P(%ZISXX,"_",I),%ZISX2=$P(%ZISXX,"_",I+1) I $E(%ZISX1,1,3)="$C(",$E(%ZISX2,1,3)="$C(" D S2 59 Q 60 L3 ; 61 N I 62 F I=1:1:$L(%ZISXX,"_") I $P(%ZISXX,"_",I)["+","$("'[$E($P(%ZISXX,"_",I)),")"'[$E($P(%ZISXX,"_",I),$L($P(%ZISXX,"_",I))) S $P(%ZISXX,"_",I)="("_$P(%ZISXX,"_",I)_")" 63 Q 64 STAR ;S ZISNUM="" F %ZISI=0:0 S ZISXL=ZISXL+1 S ZISCH=$E(%ZISXX,ZISXL) S:ZISCH?1N ZISNUM=ZISNUM_ZISCH I ZISCH=""!(ZISCH=",") S %ZISYY=%ZISYY_"$C("_+ZISNUM_")",ZISXL=ZISXL-1 Q 65 S ZISNUM="" F %ZISI=0:0 S ZISXL=ZISXL+1 S ZISCH=$E(%ZISXX,ZISXL) S:ZISCH'=""&(ZISCH'=",") ZISNUM=ZISNUM_ZISCH I ZISCH=""!(ZISCH=",") S %ZISYY=%ZISYY_"$C("_ZISNUM_")",ZISXL=ZISXL-1 Q 66 Q 67 QUOTE S %ZISYY=%ZISYY_ZISCH F %ZISI=0:0 S ZISXL=ZISXL+1 S ZISCH=$E(%ZISXX,ZISXL),%ZISYY=%ZISYY_ZISCH I ZISCH=ZISQ!(ZISXL'<ZISXLN) Q 68 Q 69 DOLR ;Looking for $C. 70 I "IXY"[$E(%ZISXX,ZISXL+1) S %ZISYY=%ZISYY_"$"_$E(%ZISXX,ZISXL+1) S ZISXL=ZISXL+1 Q 71 I "ACDEFJLNOPRSTV"[$E(%ZISXX,ZISXL+1)&($E(%ZISXX,ZISXL+2)="(") S %ZISYY=%ZISYY_"$"_$E(%ZISXX,ZISXL+1),ZISXL=ZISXL+2 D PAREN Q 72 S %ZISYY=%ZISYY_"$" ;p440 73 Q 74 PAREN S %ZISYY=%ZISYY_"(",ZISEND=")",%ZISNP=%ZISNP+1 D SCAN S %ZISNP=%ZISNP-1 75 Q 76 SCAN F %ZISI=0:0 S ZISXL=ZISXL+1,ZISCH=$E(%ZISXX,ZISXL) D S1 Q:ZISXL'<ZISXLN!(ZISEND=ZISCH&(%ZISNP)) 77 Q 78 S1 I ZISCH=ZISQ D QUOTE Q 79 I ZISCH="$" D DOLR Q 80 I ZISCH="(" D PAREN Q 81 S %ZISYY=%ZISYY_ZISCH 82 Q 83 ; 84 S2 ;MERGE $C 85 S %ZISX1=$E(%ZISX1,1,$L(%ZISX1)-1),%ZISX2=","_$E(%ZISX2,4,$L(%ZISX2)) 86 S $P(%ZISXX,"_",I,I+1)=%ZISX1_%ZISX2 87 N I D L2 88 Q 1 %ZISS1 ;AC/SFISC - Collect screen parameters 5/29/88 2:02 PM ;11/05/97 08:40 2 ;;8.0;KERNEL;**69**;JUL 10, 1995 3 VALID D L K %ZISI,%ZISNP,ZISCH,ZISEND,ZISNUM,ZISQ,ZISXL,ZISXLN Q 4 ; 5 SET2 S %ZISFN="" F %ZISZ=0:0 S %ZISFN=$O(%ZISZ(%ZISFN)) Q:%ZISFN="" I $D(%ZISZ(%ZISFN))#2 S %ZISXX=%ZISZ(%ZISFN) D INDCK 6 Q 7 INDCK S %ZISY="" 8 I "IOEFLD^IOSTBM"[%ZISFN S @%ZISFN=%ZISXX Q 9 I %ZISXX]"" S @("%ZISY="_%ZISXX) 10 ;E S @("%ZISY="_"""""") 11 I $E(%ZISFN,1,2)="IO" S @%ZISFN=%ZISY 12 E S @("IO"_$E(%ZISFN,1,6))=%ZISY 13 Q:'$D(%ZIS)#2 Q:%ZIS'["I" Q:'$D(%ZISZ(%ZISFN,1)) 14 SRAY S %=%ZISY,%ZISY=$A($E(%ZISY,1)) 15 F %1=2:1:$L(%) S %ZISY=%ZISY_$S($A(%,%1)<32:$A(%,%1),$A(%,%1)=127:127,1:$E(%,%1)) 16 S IOIS(%ZISY)=%ZISFN 17 Q 18 CHECK ;Entry point called from input transforms of fields in DEV/TT files. 19 S %ZISXX=X D L S X=%ZISYY K %ZISXX,%ZISYY,%ZISI,%ZISNP,%ZISX1,%ZISX2,ZISCH,ZISNUM,ZISQ,ZISXL,ZISXLN 20 Q 21 CHECK1 ;Entry point called from input transforms of fields in DEV/TT files. 22 S %ZISXX=$S(X?1"W ".E:$E(X,3,$L(X)),1:X) 23 D L S X=$S(X?1"W ".E:"W "_%ZISYY,1:%ZISYY) K %ZISXX,%ZISYY,%ZISI,%ZISNP,%ZISX1,%ZISX2,ZISCH,ZISNUM,ZISQ,ZISXL,ZISXLN 24 Q 25 FORM ;Entry point called from input transforms of fields in DEV/TT files. 26 Q:$L(X,"_")'>1 27 ;F %ZISSI=1:1:$L(X,"_") S %ZISX1=$P(X,"_",%ZISSI) I %ZISX1]"","#?!"[$E(%ZISX1) S X=$S(%ZISSI=1:"",1:$P(X,"_",1,%ZISSI-1)_",")_%ZISX1_$S(%ZISSI<$L(X,"_"):","_$P(X,"_",%ZISSI+1,255),1:"") W !,%ZISSI_"==>"_X 28 S %ZISSY="" 29 F %ZISSI=1:1:$L(X,"_") S %ZISSY=%ZISSY_$P(X,"_",%ZISSI)_$S($P(X,"_",%ZISSI+1)="":"","#?!"[$E($P(X,"_",%ZISSI+1)):",","#?!"[$E($P(X,"_",%ZISSI)):",",1:"_") 30 S X=%ZISSY K %ZISSI,%ZISSY 31 Q 32 ; 33 L S ZISQ="""",%ZISNP=0,ZISXLN=$L(%ZISXX) I 'ZISXLN S %ZISYY="" Q 34 S (ZISXL)=0,%ZISYY="" F %ZISI=0:0 S ZISXL=ZISXL+1 S ZISCH=$E(%ZISXX,ZISXL) D L1 Q:ZISXL'<ZISXLN 35 ;I $L(%ZISYY,"$C(")>2,%ZISYY[")_$C(" S %ZISXX=%ZISYY D L2,L3 S %ZISYY=%ZISXX Q 36 S %ZISXX=%ZISYY D L2,L3 S %ZISYY=%ZISXX 37 Q 38 L1 I ZISCH="_"!(ZISCH=",") S %ZISYY=%ZISYY_"_" Q 39 I ZISCH=ZISQ D QUOTE Q 40 I ZISCH="$" D DOLR Q 41 I ZISCH="*" D STAR Q 42 I ZISCH="(" D PAREN Q 43 S %ZISYY=%ZISYY_ZISCH Q 44 L2 F I=1:1:$L(%ZISXX,"_") S %ZISX1=$P(%ZISXX,"_",I),%ZISX2=$P(%ZISXX,"_",I+1) I $E(%ZISX1,1,3)="$C(",$E(%ZISX2,1,3)="$C(" D S2 45 Q 46 L3 F I=1:1:$L(%ZISXX,"_") I $P(%ZISXX,"_",I)["+","$("'[$E($P(%ZISXX,"_",I)),")"'[$E($P(%ZISXX,"_",I),$L($P(%ZISXX,"_",I))) S $P(%ZISXX,"_",I)="("_$P(%ZISXX,"_",I)_")" 47 Q 48 STAR ;S ZISNUM="" F %ZISI=0:0 S ZISXL=ZISXL+1 S ZISCH=$E(%ZISXX,ZISXL) S:ZISCH?1N ZISNUM=ZISNUM_ZISCH I ZISCH=""!(ZISCH=",") S %ZISYY=%ZISYY_"$C("_+ZISNUM_")",ZISXL=ZISXL-1 Q 49 S ZISNUM="" F %ZISI=0:0 S ZISXL=ZISXL+1 S ZISCH=$E(%ZISXX,ZISXL) S:ZISCH'=""&(ZISCH'=",") ZISNUM=ZISNUM_ZISCH I ZISCH=""!(ZISCH=",") S %ZISYY=%ZISYY_"$C("_ZISNUM_")",ZISXL=ZISXL-1 Q 50 Q 51 QUOTE S %ZISYY=%ZISYY_ZISCH F %ZISI=0:0 S ZISXL=ZISXL+1 S ZISCH=$E(%ZISXX,ZISXL),%ZISYY=%ZISYY_ZISCH I ZISCH=ZISQ!(ZISXL'<ZISXLN) Q 52 Q 53 DOLR ;LOOKING FOR $C. 54 I "IXY"[$E(%ZISXX,ZISXL+1) S %ZISYY=%ZISYY_"$"_$E(%ZISXX,ZISXL+1) S ZISXL=ZISXL+1 Q 55 I "ACDEFJLNOPRSTV"[$E(%ZISXX,ZISXL+1)&($E(%ZISXX,ZISXL+2)="(") S %ZISYY=%ZISYY_"$"_$E(%ZISXX,ZISXL+1),ZISXL=ZISXL+2 D PAREN 56 Q 57 PAREN S %ZISYY=%ZISYY_"(",ZISEND=")",%ZISNP=%ZISNP+1 D SCAN S %ZISNP=%ZISNP-1 Q 58 SCAN F %ZISI=0:0 S ZISXL=ZISXL+1,ZISCH=$E(%ZISXX,ZISXL) D S1 Q:ZISXL'<ZISXLN!(ZISEND=ZISCH&(%ZISNP)) 59 Q 60 S1 I ZISCH=ZISQ D QUOTE Q 61 I ZISCH="$" D DOLR Q 62 I ZISCH="(" D PAREN Q 63 S %ZISYY=%ZISYY_ZISCH Q 64 ; 65 S2 ;MERGE $C 66 S %ZISX1=$E(%ZISX1,1,$L(%ZISX1)-1),%ZISX2=","_$E(%ZISX2,4,$L(%ZISX2)) 67 S $P(%ZISXX,"_",I,I+1)=%ZISX1_%ZISX2 68 N I D L2 69 Q -
WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZTLOAD4.m
r613 r623 1 %ZTLOAD4 ;SEA/RDS-TaskMan: P I: Is Queued? ;1/24/08 16:15 2 ;;8.0;KERNEL;**440**;JUL 10, 1995;Build 13 3 ;Per VHA Directive 2004-038, this routine should not be modified 4 ;Call with ZTSK, [ZTCPU]; Return ZTSK() 5 INPUT ;check input parameters for error conditions 6 N %,$ES,$ET,%ZTVOL,ZTREC,ZTD,ZT1,ZT2,ZT3 7 I $D(ZTSK)[0 S ZTSK="" 8 I $D(ZTSK)>1 S %=ZTSK K ZTSK S ZTSK=% 9 I ZTSK<1!(ZTSK\1'=ZTSK) S ZTSK="",ZTSK(0)="",ZTSK("E")="IT" G QUIT 10 S ZTSK(0)="",ZTSK("E")="U",$ET="Q:$ES S $EC="""" G QUIT^%ZTLOAD4" 11 S %ZTVOL=^%ZOSF("VOL") 12 I $D(ZTCPU)[0 S ZTCPU=%ZTVOL 13 I ZTCPU="" S ZTCPU=%ZTVOL 14 I ZTCPU'=%ZTVOL G THERE 15 ; 16 HERE ;lookup task's status on current volume set 17 L +^%ZTSK(ZTSK):1 18 I $D(^%ZTSK(ZTSK,0))[0 S ZTSK("E")="I" G QUIT 19 S ZTREC=^%ZTSK(ZTSK,0),ZTD=$G(^(.04)) 20 S ZTSK("DUZ")=$P(ZTREC,U,3),ZTSK("D")=$P(ZTREC,U,6) ;scheduled $H 21 I ZTD]"",$D(^%ZTSCH(ZTD,ZTSK))#2 S ZTSK(0)=1 G QUIT 22 I ZTD]"",$D(^%ZTSCH("JOB",ZTD,ZTSK))#2 S ZTSK(0)=1 G QUIT 23 ; 24 S ZT1="" F S ZT1=$O(^%ZTSCH(ZT1)) Q:'ZT1 I $D(^(ZT1,ZTSK))#2 S ZTSK(0)=1 G QUIT 25 S ZT1="IO",ZT2="" F S ZT2=$O(^%ZTSCH(ZT1,ZT2)),ZT3="" Q:ZT2="" F S ZT3=$O(^%ZTSCH(ZT1,ZT2,ZT3)) Q:ZT3="" I $D(^(ZT3,ZTSK))#2 S ZTSK(0)=1 G QUIT 26 S ZT1="JOB",ZT2="" F S ZT2=$O(^%ZTSCH(ZT1,ZT2)) Q:ZT2="" I $D(^(ZT2,ZTSK))#2 S ZTSK(0)=1 G QUIT 27 S ZT1="LINK",ZT2="" F S ZT2=$O(^%ZTSCH(ZT1,ZT2)),ZT3="" Q:ZT2="" F S ZT3=$O(^%ZTSCH(ZT1,ZT2,ZT3)) Q:ZT3="" I $D(^(ZT3,ZTSK))#2 S ZTSK(0)=1 G QUIT 28 S ZTSK(0)=0 29 ; 30 QUIT ;cleanup and quit 31 L:ZTSK -^%ZTSK(ZTSK) ;K %ZTCPU,%ZTM,%ZTM1,%ZTM2,%ZTMAST,%ZTVOL,X,Y,ZT,ZT1,ZT2,ZT3,ZTCPU,ZTD,ZTREC 32 I ZTSK(0)]"" K ZTSK("E") Q 33 I ZTSK("E")'="U" Q 34 S ZTSK("E",0)=$$EC^%ZOSV 35 Q 36 ; 37 THERE ;rest of code looks up task's status on some other volume set 38 N %ZTCPU,%ZTM,X,Y 39 ; 40 FILES ;find TaskMan files on the volume set to be searched 41 S %ZTCPU=$O(^%ZIS(14.5,"B",ZTCPU,"")) 42 I %ZTCPU="" S ZTSK("E")="IS" G QUIT 43 S %ZTM=$P(^%ZOSF("MGR"),",") 44 S %ZTM=$S($D(^%ZIS(14.5,%ZTCPU,0))[0:%ZTM,$P(^(0),U,6)="":%ZTM,1:$P(^(0),U,6)) 45 S X=%ZTM,Y=ZTCPU 46 S ZTSK("E")="LS",ZT=$D(^[X,Y]%ZTSK(0)),ZTSK("E")="U" ; check link 47 ; 48 SEARCH ;find out if task is queued on that volume set 49 I $D(^[X,Y]%ZTSK(ZTSK,0))[0 S ZTSK("E")="I" G QUIT 50 S ZTREC=^[X,Y]%ZTSK(ZTSK,0),ZTD=$G(^(.04)) 51 S ZTSK("DUZ")=$P(ZTREC,U,3),ZTSK("D")=$P(ZTREC,U,6) 52 I ZTD]"",$D(^[X,Y]%ZTSCH(ZTD,ZTSK))#2 S ZTSK(0)=1 G QUIT 53 I ZTD]"",$D(^[X,Y]%ZTSCH("JOB",ZTD,ZTSK))#2 S ZTSK(0)=1 G QUIT 54 ; 55 S ZT1="" F S ZT1=$O(^[X,Y]%ZTSCH(ZT1)) Q:'ZT1 I $D(^(ZT1,ZTSK))#2 S ZTSK(0)=1 G QUIT 56 S ZT1="IO",ZT2="" F S ZT2=$O(^[X,Y]%ZTSCH(ZT1,ZT2)),ZT3="" Q:ZT2="" F S ZT3=$O(^[X,Y]%ZTSCH(ZT1,ZT2,ZT3)) Q:ZT3="" I $D(^(ZT3,ZTSK))#2 S ZTSK(0)=1 G QUIT 57 S ZT1="JOB",ZT2="" F S ZT2=$O(^[X,Y]%ZTSCH(ZT1,ZT2)) Q:ZT2="" I $D(^(ZT2,ZTSK))#2 S ZTSK(0)=1 G QUIT 58 S ZT1="LINK",ZT2="" F S ZT2=$O(^[X,Y]%ZTSCH(ZT1,ZT2)),ZT3="" Q:ZT2="" F S ZT3=$O(^[X,Y]%ZTSCH(ZT1,ZT2,ZT3)) Q:ZT3="" I $D(^(ZT3,ZTSK))#2 S ZTSK(0)=1 G QUIT 59 S ZTSK(0)=0 G QUIT 60 ; 1 %ZTLOAD4 ;SEA/RDS-TaskMan: P I: Is Queued? ;7/26/91 11:55 ; 2 ;;8.0;KERNEL;;JUL 10, 1995 3 ;;7.0; 4 ; 5 INPUT ;check input parameters for error conditions 6 I $D(ZTSK)[0 S ZTSK="" 7 I $D(ZTSK)>1 S ZTLOAD=ZTSK K ZTSK S ZTSK=ZTLOAD K ZTLOAD 8 I ZTSK<1!(ZTSK\1'=ZTSK) S ZTSK="",ZTSK(0)="",ZTSK("E")="IT" G QUIT 9 S ZTSK(0)="",ZTSK("E")="U",X="QUIT^%ZTLOAD3",@^%ZOSF("TRAP") 10 S %ZTVOL=^%ZOSF("VOL") 11 I $D(ZTCPU)[0 S ZTCPU=%ZTVOL 12 I ZTCPU="" S ZTCPU=%ZTVOL 13 I ZTCPU'=%ZTVOL G THERE 14 ; 15 HERE ;lookup task's status on current volume set 16 L +^%ZTSK(ZTSK) I $D(^%ZTSK(ZTSK,0))[0 S ZTSK("E")="I" G QUIT 17 S ZTREC=^%ZTSK(ZTSK,0),ZTD=$P(ZTREC,U,6) 18 S ZTSK("DUZ")=$P(ZTREC,U,3),ZTSK("D")=ZTD 19 I ZTD]"",$D(^%ZTSCH(ZTD,ZTSK))#2 S ZTSK(0)=1 G QUIT 20 I ZTD]"",$D(^%ZTSCH("JOB",ZTD,ZTSK))#2 S ZTSK(0)=1 G QUIT 21 ; 22 S ZT1="" F ZT=0:0 S ZT1=$O(^%ZTSCH(ZT1)) Q:'ZT1 I $D(^(ZT1,ZTSK))#2 S ZTSK(0)=1 G QUIT 23 S ZT1="IO",ZT2="" F ZT=0:0 S ZT2=$O(^%ZTSCH(ZT1,ZT2)),ZT3="" Q:ZT2="" F ZT=0:0 S ZT3=$O(^%ZTSCH(ZT1,ZT2,ZT3)) Q:ZT3="" I $D(^(ZT3,ZTSK))#2 S ZTSK(0)=1 G QUIT 24 S ZT1="JOB",ZT2="" F ZT=0:0 S ZT2=$O(^%ZTSCH(ZT1,ZT2)) Q:ZT2="" I $D(^(ZT2,ZTSK))#2 S ZTSK(0)=1 G QUIT 25 S ZT1="LINK",ZT2="" F ZT=0:0 S ZT2=$O(^%ZTSCH(ZT1,ZT2)),ZT3="" Q:ZT2="" F ZT=0:0 S ZT3=$O(^%ZTSCH(ZT1,ZT2,ZT3)) Q:ZT3="" I $D(^(ZT3,ZTSK))#2 S ZTSK(0)=1 G QUIT 26 S ZTSK(0)=0 27 ; 28 QUIT ;cleanup and quit 29 L:ZTSK -^%ZTSK(ZTSK) K %ZTCPU,%ZTM,%ZTM1,%ZTM2,%ZTMAST,%ZTVOL,X,Y,ZT,ZT1,ZT2,ZT3,ZTCPU,ZTD,ZTREC 30 I ZTSK(0)]"" K ZTSK("E") Q 31 I ZTSK("E")'="U" Q 32 S ZTSK("E",0)=$$EC^%ZOSV 33 Q 34 ; 35 THERE ;rest of code looks up task's status on some other volume set 36 ; 37 FILES ;find TaskMan files on the volume set to be searched 38 S %ZTCPU=$O(^%ZIS(14.5,"B",ZTCPU,"")) 39 I %ZTCPU="" S ZTSK("E")="IS" G QUIT 40 S %ZTM=$P(^%ZOSF("MGR"),",") 41 S %ZTM=$S($D(^%ZIS(14.5,%ZTCPU,0))[0:%ZTM,$P(^(0),U,6)="":%ZTM,1:$P(^(0),U,6)) 42 S X=%ZTM,Y=ZTCPU 43 S ZTSK("E")="LS",ZT=$D(^[X,Y]%ZTSK(0)),ZTSK("E")="U" ; check link 44 ; 45 SEARCH ;find out if task is queued on that volume set 46 I $D(^[X,Y]%ZTSK(ZTSK,0))[0 S ZTSK("E")="I" G QUIT 47 S ZTREC=^[X,Y]%ZTSK(ZTSK,0),ZTD=$P(ZTREC,U,6) 48 S ZTSK("DUZ")=$P(ZTREC,U,3),ZTSK("D")=ZTD 49 I ZTD]"",$D(^[X,Y]%ZTSCH(ZTD,ZTSK))#2 S ZTSK(0)=1 G QUIT 50 I ZTD]"",$D(^[X,Y]%ZTSCH("JOB",ZTD,ZTSK))#2 S ZTSK(0)=1 G QUIT 51 ; 52 S ZT1="" F ZT=0:0 S ZT1=$O(^[X,Y]%ZTSCH(ZT1)) Q:'ZT1 I $D(^(ZT1,ZTSK))#2 S ZTSK(0)=1 G QUIT 53 S ZT1="IO",ZT2="" F ZT=0:0 S ZT2=$O(^[X,Y]%ZTSCH(ZT1,ZT2)),ZT3="" Q:ZT2="" F ZT=0:0 S ZT3=$O(^[X,Y]%ZTSCH(ZT1,ZT2,ZT3)) Q:ZT3="" I $D(^(ZT3,ZTSK))#2 S ZTSK(0)=1 G QUIT 54 S ZT1="JOB",ZT2="" F ZT=0:0 S ZT2=$O(^[X,Y]%ZTSCH(ZT1,ZT2)) Q:ZT2="" I $D(^(ZT2,ZTSK))#2 S ZTSK(0)=1 G QUIT 55 S ZT1="LINK",ZT2="" F ZT=0:0 S ZT2=$O(^[X,Y]%ZTSCH(ZT1,ZT2)),ZT3="" Q:ZT2="" F ZT=0:0 S ZT3=$O(^[X,Y]%ZTSCH(ZT1,ZT2,ZT3)) Q:ZT3="" I $D(^(ZT3,ZTSK))#2 S ZTSK(0)=1 G QUIT 56 S ZTSK(0)=0 G QUIT 57 ;
Note:
See TracChangeset
for help on using the changeset viewer.
