ACHSPOST ; IHS/ITSC/TPF/PMF - POST INIT FOR CHS DENIALS/DEFERRED SVCS ; JUL 10, 2008
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**14**;JUN 11,2001
;3.1*14 12.4.2007 IHS/OIT/FCJ ADDED CSV CHANGES
;
S $ZT="ERROR^"_$ZN
;
;if this is a restart, certain vars won't be set. we can set
;them now, restart or not, and no harm done
S U="^"
S ACHSVERS="V"_$P($T(+2),";",3)
S $P(LINE,"*",81)=""
;
;set the time, record the start
S %H=$H D YX^%DTC S NOW=Y
S ^ACHSINST(ACHSVERS,$ZN,"ENTERED")=NOW
;
I $D(^ACHSINST(ACHSVERS,"ERROR")) S ^ACHSINST(ACHSVERS,"ERROR","PREVIOUS ERRORS HAVE NOT BEEN CLEARED")=NOW S ERROR=1,XPDABORT=1 D START^ACHSPOSM(ERROR) Q
;
;
I '$D(^ACHSINST(ACHSVERS,"ACHSPRE","FINISHED")) W !!,"ACHSPOST IS DEPENDENT ON ACHSPRE!!" S XPDABORT=1,ERROR=1,^ACHSINST(ACHSVERS,"ERROR","ATTEMPT VIA "_$ZN,"CHS INSTALL","STATUS")="ACHSPRE NOT RUN"_U_NOW D START^ACHSPOSM(ERROR) Q
;
;
N ACHD,ACHDPT,ACHDX,ACHDY,ACHDZ,DA,DIC,DIE,DIK,DD,DO,DR
;
W !!,"Beginning CHS 3.1 Post Init at ",$$FMTE^XLFDT(NOW),!!
;
;
;
D DIVCHK ;CHECK ACTIVE DIVISIONS ON THIS SYSTEM
;USED LATER TO SET UP DICTIONARY GLOBALS
;
;
W !!,LINE
D DDCHECK ;CHECK TO SEE IF DENIAL DATA DICTIONARIES WERE INITILAIZED
;PROPERLY
;
I ERROR=2 D
.W !!,"WARNING: The following files may have an error in the zero"
.W !,"node of the data dictionary entry. Please report this to ITSC"
.W !!
.S FILE=""
.F S FILE=$O(ERRLIST(FILE)) Q:FILE="" D
..S FILENAME=$O(^DD(FILE,0,"NM",""))
..W !?10,FILE,?20,FILENAME
.D START^ACHSPOSM(ERROR)
;
W !!,LINE
;
;THE FOLLOWING DATA IS ONLY LOADED IF THE DATA DOES NOT ALREADY EXIST
;ON THE INSTALLING SYSTEM. EXCEPT DENIAL REASONS. EXISTING DENIAL
;ARE DE-ACTIVATED AND NEW ONES APPROVED BY CHS WORKGROUP ARE ADDED.
;
D ^ACHSPOS1 ;DEFERRED SERVICE LETTER FORCE ENTRY
; DENIAL STATUS FORCE ENTRY
;
D ^ACHSPOS2 ;CALLS ACHSPOS3, DATA FOR DENIAL REASONS
;
D ^ACHSPOS4 ;DATA FOR DENIAL FACILITY FILE
;
D ^ACHSPOS5 ;DATA FOR MEDICAL PRIORITY FILE
;
D ^ACHSPOS6 ; DATA FOR DEFERRED SERVICES CATEGORY FILE
;
D ^ACHSCONV ;CONVERT CHS DENIAL DATA TO ACHS DATA STRUCTURE
;
D KEYASS ;ASSIGN THE 'ACHSZMENU' KEY TO ALL USERS WHO HAVE THE
;'ACHSMENU' OPTION
;
;D PULLCPT ;PULL ALL CPT ENTRIES IN ALL CHS DOCUMENTS AND DELETE
; ;POINTERS TO CPT ENTRIES WITH "unknown" IN PIECE 2 OF
; ;NODE 1
;
D ^ACHSXREF ;LOOK AT DANGLING X-REFS IN DOCUMENT FILE AND DELETE
; ALSO WILL REPORT ON POSSIBLE ENTRIES THAT MAY BE FIXED
;
S %H=$H D YX^%DTC S NOW=Y
S ^ACHSINST(ACHSVERS,$ZN,"FINISHED")=NOW
;
;
;
Q
;
;GET LIST OF ALL DIVISIONS ASSIGNED TO ACTIVE USERS ON THE SYSTEM
DIVCHK ;EP from ACHSPOS4
S %H=$H D YX^%DTC S NOW=Y
S ^ACHSINST(ACHSVERS,"DIVCHK^"_$ZN,"ENTERED")=NOW
;
;
W !!,LINE
W !!,"The following is a list of active facilities that have been"
W !,"assigned to active users. You may want to review this list"
W !,"to determine whether these are correct or not."
;
W !!,"If the 'CHS DENIAL FACILITY' file does NOT exist, the install"
W !,"will create an entry in the 'CHS DENIAL FACILITY' file so"
W !,"denials can be entered for these facilities. Otherwise the"
W !,"Site Manager will have to enter new denial facilities as"
W !,"required."
W !!
S ACHSPERS=0
F S ACHSPERS=$O(^VA(200,ACHSPERS)) Q:+ACHSPERS=0 D
.Q:$P($G(^VA(200,ACHSPERS,0)),U,11)'="" ;TERMINATION DATE
.Q:$P($G(^VA(200,ACHSPERS,"PS")),U,4)'="" ;INACTIVE DATE
.S ACHSDIV=0
.F S ACHSDIV=$O(^VA(200,ACHSPERS,2,ACHSDIV)) Q:+ACHSDIV=0 D
..;IS THE 'INACTIVE FACILITY FLAG' SET?
..Q:$P($G(^DIC(4,ACHSDIV,99)),U,4)="Y"!($P($G(^DIC(4,ACHSDIV,99)),U,4)="y")
..S ^ACHSINST(ACHSVERS,$ZN,"ACTIVE FACILITIES",ACHSDIV)=$P($G(^DIC(4,ACHSDIV,0)),U)
;FOLLOWING JUST FOR TESTING
W !!,"FACILITY IEN",?15,"FACILITY NAME"
W !,"------------",?15,"-------------"
S ACHSDIV=""
F S ACHSDIV=$O(^ACHSINST(ACHSVERS,$ZN,"ACTIVE FACILITIES",ACHSDIV)) Q:ACHSDIV="" D
.S ACHSDNM=$P($G(^DIC(4,ACHSDIV,0),"UNDEFINED"),U)
.W !,ACHSDIV,?15,ACHSDNM
;
W !!,LINE
S %H=$H D YX^%DTC S NOW=Y
S ^ACHSINST(ACHSVERS,"DIVCHK^"_$ZN,"FINISHED")=NOW
Q
;
;ASSIGN 'ACHSZMENU' KEY TO 'ACHSMENU' OPTION HOLDERS
KEYASS ;
S %H=$H D YX^%DTC S NOW=Y
S CURDATE=X
S OKEYNUM=$O(^DIC(19.1,"B","ACHSZMENU","")) ;GET IEN OF OLD MENU KEY
;
S NKEYNUM=$O(^DIC(19.1,"B","ACHSZDEFDENMENU","")) ;NEW KEY NUMBER
Q:NKEYNUM=""
S PERSIEN=0
F S PERSIEN=$O(^VA(200,PERSIEN)) Q:+PERSIEN=0 D
.;QUIT IF THE PERSON DOESN'T HAVE EITHER OF THE NEW OR OLD KEYS
.Q:'$D(^VA(200,PERSIEN,51,"B",OKEYNUM))&('$D(^VA(200,PERSIEN,51,"B",OKEYNUM)))
.W !!,"PERSON CURRENTLY HAS NEW OR OLD KEY: ",!,$P($G(^VA(200,PERSIEN,0)),U)
.S TERMDT=$P($G(^VA(200,PERSIEN,0)),U,11)
.S:TERMDT="" TERMDT=9999999
.;
.I TERMDT<CURDATE!(TERMDT=CURDATE) W !,"PERSON DEACTIVATED! KEY NOT ADDED" Q
.I $D(^VA(200,PERSIEN,51,"B",NKEYNUM)) S X="ACHSZMENU",DA(1)=PERSIEN,DIC(0)="L",DIC="^VA(200,"_DA(1)_",51,",DLAYGO=200 D ^DIC W !,"PERSON ALREADY HAS NEW KEY! ASSIGNING OLD KEY"
.I $D(^VA(200,PERSIEN,51,"B",OKEYNUM)) S X="ACHSZDEFDENMENU",DA(1)=PERSIEN,DIC(0)="L",DIC="^VA(200,"_DA(1)_",51,",DLAYGO=200 D ^DIC W !,"PERSON ALREADY HAS NEW KEY! ASSIGNING OLD KEY"
.;
.S ^ACHSINST(ACHSVERS,$ZN,"KEY ASSIGNMENTS",PERSIEN)=$P($G(^VA(200,PERSIEN,0)),U)
.W ?50,"KEY ADDED TO ACTIVE USER"
;
Q
;CHECK DENIAL DATA DICTIONARIES - JUST A WARNING
DDCHECK ;
S ERROR=0
S ERRLIST=""
I $P($G(^DD(9002061,0)),U,4)'=2 D SET(9002061) S ERROR=2,ERRLIST(9002061)=""
I $P($G(^DD(9002062,0)),U,4)'=5 D SET(9002062) S ERROR=2,ERRLIST(9002062)=""
I $P($G(^DD(9002063,0)),U,4)'=2 D SET(9002063) S ERROR=2,ERRLIST(9002063)=""
I $P($G(^DD(9002064,0)),U,4)'=6 D SET(9002064) S ERROR=2,ERRLIST(9002064)=""
I $P($G(^DD(9002064.1,0)),U,4)'=2 D SET(9002064.1) S ERROR=2,ERRLIST(9002064.1)=""
I $P($G(^DD(9002065,0)),U,4)'=42 D SET(9002065) S ERROR=2,ERRLIST(9002065)=""
I $P($G(^DD(9002066,0)),U,4)'=4 D SET(9002066) S ERROR=2,ERRLIST(9002066)=""
I $P($G(^DD(9002066.5,0)),U,4)'=4 D SET(9002066.5) S ERROR=2,ERRLIST(9002066.5)=""
I $P($G(^DD(9002067,0)),U,4)'=3 D SET(9002067) S ERROR=2,ERRLIST(90020667)=""
I $P($G(^DD(9002068,0)),U,4)'=2 D SET(9002068) S ERROR=2,ERRLIST(9002068)=""
I $P($G(^DD(9002069,0)),U,4)'=14 D SET(9002069) S ERROR=2,ERRLIST(9002069)=""
I $P($G(^DD(9002070,0)),U,4)'=2 D SET(9002070) S ERROR=2,ERRLIST(9002070)=""
I $P($G(^DD(9002071,0)),U,4)'=2 D SET(9002071) S ERROR=2,ERRLIST(9002071)=""
I $P($G(^DD(9002072,0)),U,4)'=33 D SET(9002072) S ERROR=2,ERRLIST(9002072)=""
I $P($G(^DD(9002072.1,0)),U,4)'=9 D SET(9002072.1) S ERROR=2,ERRLIST(9002072.1)=""
I $P($G(^DD(9002073,0)),U,4)'=5 D SET(9002073) S ERROR=2,ERRLIST(9002073)=""
I $P($G(^DD(9002073.1,0)),U,4)'=5 D SET(9002073.1) S ERROR=2,ERRLIST(9002073.1)=""
I $P($G(^DD(9002074,0)),U,4)'=3 D SET(9002074) S ERROR=2,ERRLIST(9002074)=""
I $P($G(^DD(9002075,0)),U,4)'=2 D SET(9002075) S ERROR=2,ERRLIST(9002075)=""
I $P($G(^DD(9002076,0)),U,4)'=3 D SET(9002076) S ERROR=2,ERRLIST(9002076)=""
I $P($G(^DD(9002077,0)),U,4)'=2 D SET(9002077) S ERROR=2,ERRLIST(9002077)=""
I $P($G(^DD(9002078,0)),U,4)'=2 D SET(9002078) S ERROR=2,ERRLIST(9002078)=""
I $P($G(^DD(9002079,0)),U,4)'=15 D SET(9002079) S ERROR=2,ERRLIST(9002079)=""
I $P($G(^DD(9002080,0)),U,4)'=50 D SET(9002080) S ERROR=2,ERRLIST(9002080)=""
Q
;
;SET INSTALL GLOBAL WITH INFO
SET(NUM) ;
S %H=$H D YX^%DTC S NOW=Y
S ^ACHSINST(ACHSVERS,"WARNING",$ZN,"CHS BAD DD INSTALL",NUM)=NOW
Q
END ;
;
D KTMP,NOW^%DTC
W !!,"CHS 3.1 Post-Init Complete ",$$FMTE^XLFDT(%)
S %H=$H D YX^%DTC S NOW=Y
S ^ACHSINST(ACHSVERS,"CHS INSTALL","STATUS","INSTALL FINISHED")=NOW
;
MAIL ;
S ERROR=0
D START^ACHSPOSM(ERROR) ;NO ERROR
Q
;
;KILL TEMP DATA GLOBALS
KTMP ;
K ^TMP($J,"DEN"),^TMP($J,"FAC"),^TMP($J,"DEF"),^TMP($J,"MPRI")
Q
;
ERROR S ^ACHSINST(ACHSVERS,"ERROR",$ZN,"ERROR TRAP CALLED")=""
G ^%ET
Q
;
;GO THRU ACHS FILES AND PULL CPT POINTERS. DELETE THOSE THAT POINT TO
;CPT ENTRIES WITH THE SECOND PIECE OF THE ZERO NODE ="unknown"
PULLCPT ;
S ACHSVERS="V"_$P($T(+2),";",3)
S U="^"
D DOCCPT ;PULL CPTs FROM 'CHS FACILITY'
D DENCPT ;PULL CPTs FROM 'CHS DENIAL DATA'
D DEFCPT ;PULL CPTs FROM 'CHS DEFERRED SERVICES DATA'
;D CLEANUP ;CLEANUP ENTRIES IN ^ICPT WITH "unknown" IN SECOND
; PIECE OFNODE 0
Q
;
;GO THROUGH 'CHS FACILITY' FILE AND PULL CPT POINTERS
DOCCPT ;
S %H=$H D YX^%DTC S NOW=Y
S ^ACHSINST(ACHSVERS,"DOCCPT^"_$ZN,"ENTERED")=NOW
;
S CPTCNT=0
S FACILITY=0
F S FACILITY=$O(^ACHSF(FACILITY)) Q:+FACILITY=0 D
.;
.S DOCUMENT=0
.F DOCCNT=1:1 S DOCUMENT=$O(^ACHSF(FACILITY,"D",DOCUMENT)) Q:+DOCUMENT=0 D
..;W !,DOCUMENT
..S CPTMULT=0
..F S CPTMULT=$O(^ACHSF(FACILITY,"D",DOCUMENT,11,CPTMULT)) Q:+CPTMULT=0 D
...S CPTINFO=$G(^ACHSF(FACILITY,"D",DOCUMENT,11,CPTMULT,0))
...Q:CPTINFO=""!(CPTINFO'[("ICPT("))
...S CODE=$P($P(CPTINFO,";"),U)
...;
...;IS THIS A BAD CHS CPT ENTRY?
...;3.1*14 12.4.2007 IHS/OIT/FCJ ADDED CSV CHANGES NXT 2 LINES
...;Q:$P($G(^ICPT(CODE,0)),U,2)'="unknown" ;NO THEN QUIT
...Q:$P($$CPT^ICPTCOD(CODE),U,3)'="unknown" ;NO THEN QUIT
...S CPTCNT=CPTCNT+1 ;NUMBER OF CPT ENTRIES IN THE CHS GLOBAL
...S DA(2)=FACILITY
...S DA(1)=DOCUMENT
...S DA=CPTMULT
...S DIK="^ACHSF("_FACILITY_",""D"","_DA(1)_",11,"
...D ^DIK
...;K ^ACHSF(FACILITY,"D",DOCUMENT,11,CPTMULT)
...;K ^ACHSF(FACILITY,"D",DOCUMENT,11,"B",$P(CPTINFO,U))
...;S NUMENTRY=$P($G(^ACHSF(FACILITY,"D",DOCUMENT,11,0)),U,4)
...;S NUMENTRY=NUMENTRY-1
...;S $P(^ACHSF(FACILITY,"D",DOCUMENT,11,0),U,4)=NUMENTRY
;
;
S %H=$H D YX^%DTC S NOW=Y
S ^ACHSINST(ACHSVERS,"DOCCPT^"_$ZN,"FINISHED")=NOW
S ^ACHSINST(ACHSVERS,"DOCCPT^"_$ZN,"BAD CPT IN ^ACHSF")=CPTCNT
;
Q
;
;NOW GET CPTs FROM 'CHS DEFERRED SERVICES DATA'
;
DEFCPT ;
;
S %H=$H D YX^%DTC S NOW=Y
S ^ACHSINST(ACHSVERS,"DEFCPT^"_$ZN,"ENTERED")=NOW
;
S DEFCNT=0
S FACILITY=0
F S FACILITY=$O(^ACHSDEF(FACILITY)) Q:+FACILITY=0 D
.S DEFDOC=0
.F S DEFDOC=$O(^ACHSDEF(FACILITY,"D",DEFDOC)) Q:+DEFDOC=0 D
..S MULT=0
..F S MULT=$O(^ACHSDEF(FACILITY,"D",DEFDOC,300,MULT)) Q:+MULT=0 D
...S DEFCPT=$P($G(^ACHSDEF(FACILITY,"D",DEFDOC,300,MULT,0)),U)
...Q:DEFCPT=""
...;IS THIS POINTING TO A BAD CHS CPT ENTRY?
...;3.1*14 12.4.2007 IHS/OIT/FCJ ADDED CSV CHANGES NXT 2 LINES
...;Q:$P($G(^ICPT(DEFCPT,0)),U,2)'="unknown"
...Q:$P($$CPT^ICPTCOD(DEFCPT),U,3)'="unknown"
...S DEFCNT=DEFCNT+1
...S DA(2)=FACILITY
...S DA(1)=DEFDOC
...S DA=MULT
...S DIK="^ACHSF("_FACILITY_",""D"","_DA(1)_",300,"
...D ^DIK
...;K ^ACHSDEF(FACILITY,"D",DEFDOC,300,MULT)
...;K ^ACHSDEF(FACILITY,"D",DEFDOC,300,"B",DEFCPT)
...;S NUMENTRY=$P($G(^ACHSDEF(FACILITY,"D",DEFDOC,300,0)),U,4)
...;S NUMENTRY=NUMENTRY-1
...;S $P(^ACHSDEF(FACILITY,"D",DEFDOC,300,0),U,4)=NUMENTRY
;
S %H=$H D YX^%DTC S NOW=Y
S ^ACHSINST(ACHSVERS,"DEFCPT^"_$ZN,"FINISHED")=NOW
S ^ACHSINST(ACHSVERS,"DEFCPT^"_$ZN,"BAD CPT IN ^ACHSDEF")=DEFCNT
;
Q
;
;NOW GET CPTs FROM 'CHS DENIAL DATA' FILE
DENCPT ;
;
S %H=$H D YX^%DTC S NOW=Y
S ^ACHSINST(ACHSVERS,"DENCPT^"_$ZN,"ENTERED")=NOW
;
S DENCNT=0
S FACILITY=0
F S FACILITY=$O(^ACHSDEN(FACILITY)) Q:+FACILITY=0 D
.S DENDOC=0
.F S DENDOC=$O(^ACHSDEN(FACILITY,"D",DENDOC)) Q:+DENDOC=0 D
..S MULT=0
..F S MULT=$O(^ACHSDEN(FACILITY,"D",DENDOC,MULT)) Q:+MULT=0 D
...S DENCPT=$P($G(^ACHSDEN(FACILITY,"D",DENDOC,700,MULT,0)),U)
...Q:DENCPT=""
...;
...;IS THIS A BAD CHS CPT ENTRY?
...;3.1*14 12.4.2007 IHS/OIT/FCJ ADDED CSV CHANGES NXT 2 LINES
...;Q:$P($G(^ICPT(DENCPT,0)),U,2)'="unknown"
...Q:$P($$CPT^ICPTCOD(DENCPT),U,3)'="unknown"
...S DENCNT=DENCNT+1
...S DA(2)=FACILITY
...S DA(1)=DENDOC
...S DA=MULT
...S DIK="^ACHSF("_FACILITY_",""D"","_DA(1)_",700,"
...D ^DIK
...;K ^ACHSDEN(FACILITY,"D",DENDOC,700,MULT)
...;K ^ACHSDEN(FACILITY,"D",DENDOC,700,"B",DENCPT)
...;S NUMENTRY=$P($G(^ACHSDEN(FACILITY,"D",DENDOC,700,0)),U,4)
...;S NUMENTRY=NUMENTRY-1
...;S $P(^ACHSDEN(FACILITY,"D",DENDOC,700,0),U,4)=NUMENTRY
;
S %H=$H D YX^%DTC S NOW=Y
S ^ACHSINST(ACHSVERS,"DENCPT^"_$ZN,"FINISHED")=NOW
S ^ACHSINST(ACHSVERS,"DENCPT^"_$ZN,"BAD CPT IN ^ACHSDEN")=DENCNT
;
Q
;
;CLEANUP CPT "unknown" ENTRIES
CLEANUP ;
;
S CPTCODE=0
F S CPTCODE=$O(^ICPT(CPTCODE)) Q:+CPTCODE=0 D
.;3.1*14 12.4.2007 IHS/OIT/FCJ ADDED CSV CHANGES NXT 2 LINES
.;Q:$P($G(^ICPT(CPTCODE,0)),U,2)'="unknown"
.Q:$P($$CPT^ICPTCOD(CPTCODE),U,3)'="unknown"
.S DIK="^ICPT("
.S DA=CPTCODE
.D ^DIK
.;
Q
;
OPTS ;
;;ACHSDENADD
;;ACHSDENDELETE
;;ACHSDENDOCUMENT
;;ACHSDENEDIT
;;ACHSDENLETTER
;;ACHSDENMENU
;;ACHSDENPARM
;;ACHSDENPARMADDREA
;;ACHSDENPARMAMT
;;ACHSDENPARMBOT
;;ACHSDENPARMFAC
;;ACHSDENPARMHEAD
;;ACHSDENPARMLOF
;;ACHSDENPARMMID
;;ACHSDENPARMNUMS
;;ACHSDENPARMREA
;;ACHSDENPARMSIG
;;ACHSDENPARMUNMET
;;ACHSDENPVDRLIST
;;ACHSDENPVDRLISTNOT
;;ACHSDENREASONS
;;ACHSDENREP1
;;ACHSDENREPMENU
;;ACHSDENRPTHQ1
;;ACHSDENSTATS
;;ACHSDENUNMET
ACHSPOST ; IHS/ITSC/TPF/PMF - POST INIT FOR CHS DENIALS/DEFERRED SVCS ; JUL 10, 2008
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**14**;JUN 11,2001
+2 ;3.1*14 12.4.2007 IHS/OIT/FCJ ADDED CSV CHANGES
+3 ;
+4 SET $ZT="ERROR^"_$ZN
+5 ;
+6 ;if this is a restart, certain vars won't be set. we can set
+7 ;them now, restart or not, and no harm done
+8 SET U="^"
+9 SET ACHSVERS="V"_$PIECE($TEXT(+2),";",3)
+10 SET $PIECE(LINE,"*",81)=""
+11 ;
+12 ;set the time, record the start
+13 SET %H=$HOROLOG
DO YX^%DTC
SET NOW=Y
+14 SET ^ACHSINST(ACHSVERS,$ZN,"ENTERED")=NOW
+15 ;
+16 IF $DATA(^ACHSINST(ACHSVERS,"ERROR"))
SET ^ACHSINST(ACHSVERS,"ERROR","PREVIOUS ERRORS HAVE NOT BEEN CLEARED")=NOW
SET ERROR=1
SET XPDABORT=1
DO START^ACHSPOSM(ERROR)
QUIT
+17 ;
+18 ;
+19 IF '$DATA(^ACHSINST(ACHSVERS,"ACHSPRE","FINISHED"))
WRITE !!,"ACHSPOST IS DEPENDENT ON ACHSPRE!!"
SET XPDABORT=1
SET ERROR=1
SET ^ACHSINST(ACHSVERS,"ERROR","ATTEMPT VIA "_$ZN,"CHS INSTALL","STATUS")="ACHSPRE NOT RUN"_U_NOW
DO START^ACHSPOSM(ERROR)
QUIT
+20 ;
+21 ;
+22 NEW ACHD,ACHDPT,ACHDX,ACHDY,ACHDZ,DA,DIC,DIE,DIK,DD,DO,DR
+23 ;
+24 WRITE !!,"Beginning CHS 3.1 Post Init at ",$$FMTE^XLFDT(NOW),!!
+25 ;
+26 ;
+27 ;
+28 ;CHECK ACTIVE DIVISIONS ON THIS SYSTEM
DO DIVCHK
+29 ;USED LATER TO SET UP DICTIONARY GLOBALS
+30 ;
+31 ;
+32 WRITE !!,LINE
+33 ;CHECK TO SEE IF DENIAL DATA DICTIONARIES WERE INITILAIZED
DO DDCHECK
+34 ;PROPERLY
+35 ;
+36 IF ERROR=2
Begin DoDot:1
+37 WRITE !!,"WARNING: The following files may have an error in the zero"
+38 WRITE !,"node of the data dictionary entry. Please report this to ITSC"
+39 WRITE !!
+40 SET FILE=""
+41 FOR
SET FILE=$ORDER(ERRLIST(FILE))
IF FILE=""
QUIT
Begin DoDot:2
+42 SET FILENAME=$ORDER(^DD(FILE,0,"NM",""))
+43 WRITE !?10,FILE,?20,FILENAME
End DoDot:2
+44 DO START^ACHSPOSM(ERROR)
End DoDot:1
+45 ;
+46 WRITE !!,LINE
+47 ;
+48 ;THE FOLLOWING DATA IS ONLY LOADED IF THE DATA DOES NOT ALREADY EXIST
+49 ;ON THE INSTALLING SYSTEM. EXCEPT DENIAL REASONS. EXISTING DENIAL
+50 ;ARE DE-ACTIVATED AND NEW ONES APPROVED BY CHS WORKGROUP ARE ADDED.
+51 ;
+52 ;DEFERRED SERVICE LETTER FORCE ENTRY
DO ^ACHSPOS1
+53 ; DENIAL STATUS FORCE ENTRY
+54 ;
+55 ;CALLS ACHSPOS3, DATA FOR DENIAL REASONS
DO ^ACHSPOS2
+56 ;
+57 ;DATA FOR DENIAL FACILITY FILE
DO ^ACHSPOS4
+58 ;
+59 ;DATA FOR MEDICAL PRIORITY FILE
DO ^ACHSPOS5
+60 ;
+61 ; DATA FOR DEFERRED SERVICES CATEGORY FILE
DO ^ACHSPOS6
+62 ;
+63 ;CONVERT CHS DENIAL DATA TO ACHS DATA STRUCTURE
DO ^ACHSCONV
+64 ;
+65 ;ASSIGN THE 'ACHSZMENU' KEY TO ALL USERS WHO HAVE THE
DO KEYASS
+66 ;'ACHSMENU' OPTION
+67 ;
+68 ;D PULLCPT ;PULL ALL CPT ENTRIES IN ALL CHS DOCUMENTS AND DELETE
+69 ; ;POINTERS TO CPT ENTRIES WITH "unknown" IN PIECE 2 OF
+70 ; ;NODE 1
+71 ;
+72 ;LOOK AT DANGLING X-REFS IN DOCUMENT FILE AND DELETE
DO ^ACHSXREF
+73 ; ALSO WILL REPORT ON POSSIBLE ENTRIES THAT MAY BE FIXED
+74 ;
+75 SET %H=$HOROLOG
DO YX^%DTC
SET NOW=Y
+76 SET ^ACHSINST(ACHSVERS,$ZN,"FINISHED")=NOW
+77 ;
+78 ;
+79 ;
+80 QUIT
+81 ;
+82 ;GET LIST OF ALL DIVISIONS ASSIGNED TO ACTIVE USERS ON THE SYSTEM
DIVCHK ;EP from ACHSPOS4
+1 SET %H=$HOROLOG
DO YX^%DTC
SET NOW=Y
+2 SET ^ACHSINST(ACHSVERS,"DIVCHK^"_$ZN,"ENTERED")=NOW
+3 ;
+4 ;
+5 WRITE !!,LINE
+6 WRITE !!,"The following is a list of active facilities that have been"
+7 WRITE !,"assigned to active users. You may want to review this list"
+8 WRITE !,"to determine whether these are correct or not."
+9 ;
+10 WRITE !!,"If the 'CHS DENIAL FACILITY' file does NOT exist, the install"
+11 WRITE !,"will create an entry in the 'CHS DENIAL FACILITY' file so"
+12 WRITE !,"denials can be entered for these facilities. Otherwise the"
+13 WRITE !,"Site Manager will have to enter new denial facilities as"
+14 WRITE !,"required."
+15 WRITE !!
+16 SET ACHSPERS=0
+17 FOR
SET ACHSPERS=$ORDER(^VA(200,ACHSPERS))
IF +ACHSPERS=0
QUIT
Begin DoDot:1
+18 ;TERMINATION DATE
IF $PIECE($GET(^VA(200,ACHSPERS,0)),U,11)'=""
QUIT
+19 ;INACTIVE DATE
IF $PIECE($GET(^VA(200,ACHSPERS,"PS")),U,4)'=""
QUIT
+20 SET ACHSDIV=0
+21 FOR
SET ACHSDIV=$ORDER(^VA(200,ACHSPERS,2,ACHSDIV))
IF +ACHSDIV=0
QUIT
Begin DoDot:2
+22 ;IS THE 'INACTIVE FACILITY FLAG' SET?
+23 IF $PIECE($GET(^DIC(4,ACHSDIV,99)),U,4)="Y"!($PIECE($GET(^DIC(4,ACHSDIV,99)),U,4)="y")
QUIT
+24 SET ^ACHSINST(ACHSVERS,$ZN,"ACTIVE FACILITIES",ACHSDIV)=$PIECE($GET(^DIC(4,ACHSDIV,0)),U)
End DoDot:2
End DoDot:1
+25 ;FOLLOWING JUST FOR TESTING
+26 WRITE !!,"FACILITY IEN",?15,"FACILITY NAME"
+27 WRITE !,"------------",?15,"-------------"
+28 SET ACHSDIV=""
+29 FOR
SET ACHSDIV=$ORDER(^ACHSINST(ACHSVERS,$ZN,"ACTIVE FACILITIES",ACHSDIV))
IF ACHSDIV=""
QUIT
Begin DoDot:1
+30 SET ACHSDNM=$PIECE($GET(^DIC(4,ACHSDIV,0),"UNDEFINED"),U)
+31 WRITE !,ACHSDIV,?15,ACHSDNM
End DoDot:1
+32 ;
+33 WRITE !!,LINE
+34 SET %H=$HOROLOG
DO YX^%DTC
SET NOW=Y
+35 SET ^ACHSINST(ACHSVERS,"DIVCHK^"_$ZN,"FINISHED")=NOW
+36 QUIT
+37 ;
+38 ;ASSIGN 'ACHSZMENU' KEY TO 'ACHSMENU' OPTION HOLDERS
KEYASS ;
+1 SET %H=$HOROLOG
DO YX^%DTC
SET NOW=Y
+2 SET CURDATE=X
+3 ;GET IEN OF OLD MENU KEY
SET OKEYNUM=$ORDER(^DIC(19.1,"B","ACHSZMENU",""))
+4 ;
+5 ;NEW KEY NUMBER
SET NKEYNUM=$ORDER(^DIC(19.1,"B","ACHSZDEFDENMENU",""))
+6 IF NKEYNUM=""
QUIT
+7 SET PERSIEN=0
+8 FOR
SET PERSIEN=$ORDER(^VA(200,PERSIEN))
IF +PERSIEN=0
QUIT
Begin DoDot:1
+9 ;QUIT IF THE PERSON DOESN'T HAVE EITHER OF THE NEW OR OLD KEYS
+10 IF '$DATA(^VA(200,PERSIEN,51,"B",OKEYNUM))&('$DATA(^VA(200,PERSIEN,51,"B",OKEYNUM)))
QUIT
+11 WRITE !!,"PERSON CURRENTLY HAS NEW OR OLD KEY: ",!,$PIECE($GET(^VA(200,PERSIEN,0)),U)
+12 SET TERMDT=$PIECE($GET(^VA(200,PERSIEN,0)),U,11)
+13 IF TERMDT=""
SET TERMDT=9999999
+14 ;
+15 IF TERMDT<CURDATE!(TERMDT=CURDATE)
WRITE !,"PERSON DEACTIVATED! KEY NOT ADDED"
QUIT
+16 IF $DATA(^VA(200,PERSIEN,51,"B",NKEYNUM))
SET X="ACHSZMENU"
SET DA(1)=PERSIEN
SET DIC(0)="L"
SET DIC="^VA(200,"_DA(1)_",51,"
SET DLAYGO=200
DO ^DIC
WRITE !,"PERSON ALREADY HAS NEW KEY! ASSIGNING OLD KEY"
+17 IF $DATA(^VA(200,PERSIEN,51,"B",OKEYNUM))
SET X="ACHSZDEFDENMENU"
SET DA(1)=PERSIEN
SET DIC(0)="L"
SET DIC="^VA(200,"_DA(1)_",51,"
SET DLAYGO=200
DO ^DIC
WRITE !,"PERSON ALREADY HAS NEW KEY! ASSIGNING OLD KEY"
+18 ;
+19 SET ^ACHSINST(ACHSVERS,$ZN,"KEY ASSIGNMENTS",PERSIEN)=$PIECE($GET(^VA(200,PERSIEN,0)),U)
+20 WRITE ?50,"KEY ADDED TO ACTIVE USER"
End DoDot:1
+21 ;
+22 QUIT
+23 ;CHECK DENIAL DATA DICTIONARIES - JUST A WARNING
DDCHECK ;
+1 SET ERROR=0
+2 SET ERRLIST=""
+3 IF $PIECE($GET(^DD(9002061,0)),U,4)'=2
DO SET(9002061)
SET ERROR=2
SET ERRLIST(9002061)=""
+4 IF $PIECE($GET(^DD(9002062,0)),U,4)'=5
DO SET(9002062)
SET ERROR=2
SET ERRLIST(9002062)=""
+5 IF $PIECE($GET(^DD(9002063,0)),U,4)'=2
DO SET(9002063)
SET ERROR=2
SET ERRLIST(9002063)=""
+6 IF $PIECE($GET(^DD(9002064,0)),U,4)'=6
DO SET(9002064)
SET ERROR=2
SET ERRLIST(9002064)=""
+7 IF $PIECE($GET(^DD(9002064.1,0)),U,4)'=2
DO SET(9002064.1)
SET ERROR=2
SET ERRLIST(9002064.1)=""
+8 IF $PIECE($GET(^DD(9002065,0)),U,4)'=42
DO SET(9002065)
SET ERROR=2
SET ERRLIST(9002065)=""
+9 IF $PIECE($GET(^DD(9002066,0)),U,4)'=4
DO SET(9002066)
SET ERROR=2
SET ERRLIST(9002066)=""
+10 IF $PIECE($GET(^DD(9002066.5,0)),U,4)'=4
DO SET(9002066.5)
SET ERROR=2
SET ERRLIST(9002066.5)=""
+11 IF $PIECE($GET(^DD(9002067,0)),U,4)'=3
DO SET(9002067)
SET ERROR=2
SET ERRLIST(90020667)=""
+12 IF $PIECE($GET(^DD(9002068,0)),U,4)'=2
DO SET(9002068)
SET ERROR=2
SET ERRLIST(9002068)=""
+13 IF $PIECE($GET(^DD(9002069,0)),U,4)'=14
DO SET(9002069)
SET ERROR=2
SET ERRLIST(9002069)=""
+14 IF $PIECE($GET(^DD(9002070,0)),U,4)'=2
DO SET(9002070)
SET ERROR=2
SET ERRLIST(9002070)=""
+15 IF $PIECE($GET(^DD(9002071,0)),U,4)'=2
DO SET(9002071)
SET ERROR=2
SET ERRLIST(9002071)=""
+16 IF $PIECE($GET(^DD(9002072,0)),U,4)'=33
DO SET(9002072)
SET ERROR=2
SET ERRLIST(9002072)=""
+17 IF $PIECE($GET(^DD(9002072.1,0)),U,4)'=9
DO SET(9002072.1)
SET ERROR=2
SET ERRLIST(9002072.1)=""
+18 IF $PIECE($GET(^DD(9002073,0)),U,4)'=5
DO SET(9002073)
SET ERROR=2
SET ERRLIST(9002073)=""
+19 IF $PIECE($GET(^DD(9002073.1,0)),U,4)'=5
DO SET(9002073.1)
SET ERROR=2
SET ERRLIST(9002073.1)=""
+20 IF $PIECE($GET(^DD(9002074,0)),U,4)'=3
DO SET(9002074)
SET ERROR=2
SET ERRLIST(9002074)=""
+21 IF $PIECE($GET(^DD(9002075,0)),U,4)'=2
DO SET(9002075)
SET ERROR=2
SET ERRLIST(9002075)=""
+22 IF $PIECE($GET(^DD(9002076,0)),U,4)'=3
DO SET(9002076)
SET ERROR=2
SET ERRLIST(9002076)=""
+23 IF $PIECE($GET(^DD(9002077,0)),U,4)'=2
DO SET(9002077)
SET ERROR=2
SET ERRLIST(9002077)=""
+24 IF $PIECE($GET(^DD(9002078,0)),U,4)'=2
DO SET(9002078)
SET ERROR=2
SET ERRLIST(9002078)=""
+25 IF $PIECE($GET(^DD(9002079,0)),U,4)'=15
DO SET(9002079)
SET ERROR=2
SET ERRLIST(9002079)=""
+26 IF $PIECE($GET(^DD(9002080,0)),U,4)'=50
DO SET(9002080)
SET ERROR=2
SET ERRLIST(9002080)=""
+27 QUIT
+28 ;
+29 ;SET INSTALL GLOBAL WITH INFO
SET(NUM) ;
+1 SET %H=$HOROLOG
DO YX^%DTC
SET NOW=Y
+2 SET ^ACHSINST(ACHSVERS,"WARNING",$ZN,"CHS BAD DD INSTALL",NUM)=NOW
+3 QUIT
END ;
+1 ;
+2 DO KTMP
DO NOW^%DTC
+3 WRITE !!,"CHS 3.1 Post-Init Complete ",$$FMTE^XLFDT(%)
+4 SET %H=$HOROLOG
DO YX^%DTC
SET NOW=Y
+5 SET ^ACHSINST(ACHSVERS,"CHS INSTALL","STATUS","INSTALL FINISHED")=NOW
+6 ;
MAIL ;
+1 SET ERROR=0
+2 ;NO ERROR
DO START^ACHSPOSM(ERROR)
+3 QUIT
+4 ;
+5 ;KILL TEMP DATA GLOBALS
KTMP ;
+1 KILL ^TMP($JOB,"DEN"),^TMP($JOB,"FAC"),^TMP($JOB,"DEF"),^TMP($JOB,"MPRI")
+2 QUIT
+3 ;
ERROR SET ^ACHSINST(ACHSVERS,"ERROR",$ZN,"ERROR TRAP CALLED")=""
+1 GOTO ^%ET
+2 QUIT
+3 ;
+4 ;GO THRU ACHS FILES AND PULL CPT POINTERS. DELETE THOSE THAT POINT TO
+5 ;CPT ENTRIES WITH THE SECOND PIECE OF THE ZERO NODE ="unknown"
PULLCPT ;
+1 SET ACHSVERS="V"_$PIECE($TEXT(+2),";",3)
+2 SET U="^"
+3 ;PULL CPTs FROM 'CHS FACILITY'
DO DOCCPT
+4 ;PULL CPTs FROM 'CHS DENIAL DATA'
DO DENCPT
+5 ;PULL CPTs FROM 'CHS DEFERRED SERVICES DATA'
DO DEFCPT
+6 ;D CLEANUP ;CLEANUP ENTRIES IN ^ICPT WITH "unknown" IN SECOND
+7 ; PIECE OFNODE 0
+8 QUIT
+9 ;
+10 ;GO THROUGH 'CHS FACILITY' FILE AND PULL CPT POINTERS
DOCCPT ;
+1 SET %H=$HOROLOG
DO YX^%DTC
SET NOW=Y
+2 SET ^ACHSINST(ACHSVERS,"DOCCPT^"_$ZN,"ENTERED")=NOW
+3 ;
+4 SET CPTCNT=0
+5 SET FACILITY=0
+6 FOR
SET FACILITY=$ORDER(^ACHSF(FACILITY))
IF +FACILITY=0
QUIT
Begin DoDot:1
+7 ;
+8 SET DOCUMENT=0
+9 FOR DOCCNT=1:1
SET DOCUMENT=$ORDER(^ACHSF(FACILITY,"D",DOCUMENT))
IF +DOCUMENT=0
QUIT
Begin DoDot:2
+10 ;W !,DOCUMENT
+11 SET CPTMULT=0
+12 FOR
SET CPTMULT=$ORDER(^ACHSF(FACILITY,"D",DOCUMENT,11,CPTMULT))
IF +CPTMULT=0
QUIT
Begin DoDot:3
+13 SET CPTINFO=$GET(^ACHSF(FACILITY,"D",DOCUMENT,11,CPTMULT,0))
+14 IF CPTINFO=""!(CPTINFO'[("ICPT("))
QUIT
+15 SET CODE=$PIECE($PIECE(CPTINFO,";"),U)
+16 ;
+17 ;IS THIS A BAD CHS CPT ENTRY?
+18 ;3.1*14 12.4.2007 IHS/OIT/FCJ ADDED CSV CHANGES NXT 2 LINES
+19 ;Q:$P($G(^ICPT(CODE,0)),U,2)'="unknown" ;NO THEN QUIT
+20 ;NO THEN QUIT
IF $PIECE($$CPT^ICPTCOD(CODE),U,3)'="unknown"
QUIT
+21 ;NUMBER OF CPT ENTRIES IN THE CHS GLOBAL
SET CPTCNT=CPTCNT+1
+22 SET DA(2)=FACILITY
+23 SET DA(1)=DOCUMENT
+24 SET DA=CPTMULT
+25 SET DIK="^ACHSF("_FACILITY_",""D"","_DA(1)_",11,"
+26 DO ^DIK
+27 ;K ^ACHSF(FACILITY,"D",DOCUMENT,11,CPTMULT)
+28 ;K ^ACHSF(FACILITY,"D",DOCUMENT,11,"B",$P(CPTINFO,U))
+29 ;S NUMENTRY=$P($G(^ACHSF(FACILITY,"D",DOCUMENT,11,0)),U,4)
+30 ;S NUMENTRY=NUMENTRY-1
+31 ;S $P(^ACHSF(FACILITY,"D",DOCUMENT,11,0),U,4)=NUMENTRY
End DoDot:3
End DoDot:2
End DoDot:1
+32 ;
+33 ;
+34 SET %H=$HOROLOG
DO YX^%DTC
SET NOW=Y
+35 SET ^ACHSINST(ACHSVERS,"DOCCPT^"_$ZN,"FINISHED")=NOW
+36 SET ^ACHSINST(ACHSVERS,"DOCCPT^"_$ZN,"BAD CPT IN ^ACHSF")=CPTCNT
+37 ;
+38 QUIT
+39 ;
+40 ;NOW GET CPTs FROM 'CHS DEFERRED SERVICES DATA'
+41 ;
DEFCPT ;
+1 ;
+2 SET %H=$HOROLOG
DO YX^%DTC
SET NOW=Y
+3 SET ^ACHSINST(ACHSVERS,"DEFCPT^"_$ZN,"ENTERED")=NOW
+4 ;
+5 SET DEFCNT=0
+6 SET FACILITY=0
+7 FOR
SET FACILITY=$ORDER(^ACHSDEF(FACILITY))
IF +FACILITY=0
QUIT
Begin DoDot:1
+8 SET DEFDOC=0
+9 FOR
SET DEFDOC=$ORDER(^ACHSDEF(FACILITY,"D",DEFDOC))
IF +DEFDOC=0
QUIT
Begin DoDot:2
+10 SET MULT=0
+11 FOR
SET MULT=$ORDER(^ACHSDEF(FACILITY,"D",DEFDOC,300,MULT))
IF +MULT=0
QUIT
Begin DoDot:3
+12 SET DEFCPT=$PIECE($GET(^ACHSDEF(FACILITY,"D",DEFDOC,300,MULT,0)),U)
+13 IF DEFCPT=""
QUIT
+14 ;IS THIS POINTING TO A BAD CHS CPT ENTRY?
+15 ;3.1*14 12.4.2007 IHS/OIT/FCJ ADDED CSV CHANGES NXT 2 LINES
+16 ;Q:$P($G(^ICPT(DEFCPT,0)),U,2)'="unknown"
+17 IF $PIECE($$CPT^ICPTCOD(DEFCPT),U,3)'="unknown"
QUIT
+18 SET DEFCNT=DEFCNT+1
+19 SET DA(2)=FACILITY
+20 SET DA(1)=DEFDOC
+21 SET DA=MULT
+22 SET DIK="^ACHSF("_FACILITY_",""D"","_DA(1)_",300,"
+23 DO ^DIK
+24 ;K ^ACHSDEF(FACILITY,"D",DEFDOC,300,MULT)
+25 ;K ^ACHSDEF(FACILITY,"D",DEFDOC,300,"B",DEFCPT)
+26 ;S NUMENTRY=$P($G(^ACHSDEF(FACILITY,"D",DEFDOC,300,0)),U,4)
+27 ;S NUMENTRY=NUMENTRY-1
+28 ;S $P(^ACHSDEF(FACILITY,"D",DEFDOC,300,0),U,4)=NUMENTRY
End DoDot:3
End DoDot:2
End DoDot:1
+29 ;
+30 SET %H=$HOROLOG
DO YX^%DTC
SET NOW=Y
+31 SET ^ACHSINST(ACHSVERS,"DEFCPT^"_$ZN,"FINISHED")=NOW
+32 SET ^ACHSINST(ACHSVERS,"DEFCPT^"_$ZN,"BAD CPT IN ^ACHSDEF")=DEFCNT
+33 ;
+34 QUIT
+35 ;
+36 ;NOW GET CPTs FROM 'CHS DENIAL DATA' FILE
DENCPT ;
+1 ;
+2 SET %H=$HOROLOG
DO YX^%DTC
SET NOW=Y
+3 SET ^ACHSINST(ACHSVERS,"DENCPT^"_$ZN,"ENTERED")=NOW
+4 ;
+5 SET DENCNT=0
+6 SET FACILITY=0
+7 FOR
SET FACILITY=$ORDER(^ACHSDEN(FACILITY))
IF +FACILITY=0
QUIT
Begin DoDot:1
+8 SET DENDOC=0
+9 FOR
SET DENDOC=$ORDER(^ACHSDEN(FACILITY,"D",DENDOC))
IF +DENDOC=0
QUIT
Begin DoDot:2
+10 SET MULT=0
+11 FOR
SET MULT=$ORDER(^ACHSDEN(FACILITY,"D",DENDOC,MULT))
IF +MULT=0
QUIT
Begin DoDot:3
+12 SET DENCPT=$PIECE($GET(^ACHSDEN(FACILITY,"D",DENDOC,700,MULT,0)),U)
+13 IF DENCPT=""
QUIT
+14 ;
+15 ;IS THIS A BAD CHS CPT ENTRY?
+16 ;3.1*14 12.4.2007 IHS/OIT/FCJ ADDED CSV CHANGES NXT 2 LINES
+17 ;Q:$P($G(^ICPT(DENCPT,0)),U,2)'="unknown"
+18 IF $PIECE($$CPT^ICPTCOD(DENCPT),U,3)'="unknown"
QUIT
+19 SET DENCNT=DENCNT+1
+20 SET DA(2)=FACILITY
+21 SET DA(1)=DENDOC
+22 SET DA=MULT
+23 SET DIK="^ACHSF("_FACILITY_",""D"","_DA(1)_",700,"
+24 DO ^DIK
+25 ;K ^ACHSDEN(FACILITY,"D",DENDOC,700,MULT)
+26 ;K ^ACHSDEN(FACILITY,"D",DENDOC,700,"B",DENCPT)
+27 ;S NUMENTRY=$P($G(^ACHSDEN(FACILITY,"D",DENDOC,700,0)),U,4)
+28 ;S NUMENTRY=NUMENTRY-1
+29 ;S $P(^ACHSDEN(FACILITY,"D",DENDOC,700,0),U,4)=NUMENTRY
End DoDot:3
End DoDot:2
End DoDot:1
+30 ;
+31 SET %H=$HOROLOG
DO YX^%DTC
SET NOW=Y
+32 SET ^ACHSINST(ACHSVERS,"DENCPT^"_$ZN,"FINISHED")=NOW
+33 SET ^ACHSINST(ACHSVERS,"DENCPT^"_$ZN,"BAD CPT IN ^ACHSDEN")=DENCNT
+34 ;
+35 QUIT
+36 ;
+37 ;CLEANUP CPT "unknown" ENTRIES
CLEANUP ;
+1 ;
+2 SET CPTCODE=0
+3 FOR
SET CPTCODE=$ORDER(^ICPT(CPTCODE))
IF +CPTCODE=0
QUIT
Begin DoDot:1
+4 ;3.1*14 12.4.2007 IHS/OIT/FCJ ADDED CSV CHANGES NXT 2 LINES
+5 ;Q:$P($G(^ICPT(CPTCODE,0)),U,2)'="unknown"
+6 IF $PIECE($$CPT^ICPTCOD(CPTCODE),U,3)'="unknown"
QUIT
+7 SET DIK="^ICPT("
+8 SET DA=CPTCODE
+9 DO ^DIK
+10 ;
End DoDot:1
+11 QUIT
+12 ;
OPTS ;
+1 ;;ACHSDENADD
+2 ;;ACHSDENDELETE
+3 ;;ACHSDENDOCUMENT
+4 ;;ACHSDENEDIT
+5 ;;ACHSDENLETTER
+6 ;;ACHSDENMENU
+7 ;;ACHSDENPARM
+8 ;;ACHSDENPARMADDREA
+9 ;;ACHSDENPARMAMT
+10 ;;ACHSDENPARMBOT
+11 ;;ACHSDENPARMFAC
+12 ;;ACHSDENPARMHEAD
+13 ;;ACHSDENPARMLOF
+14 ;;ACHSDENPARMMID
+15 ;;ACHSDENPARMNUMS
+16 ;;ACHSDENPARMREA
+17 ;;ACHSDENPARMSIG
+18 ;;ACHSDENPARMUNMET
+19 ;;ACHSDENPVDRLIST
+20 ;;ACHSDENPVDRLISTNOT
+21 ;;ACHSDENREASONS
+22 ;;ACHSDENREP1
+23 ;;ACHSDENREPMENU
+24 ;;ACHSDENRPTHQ1
+25 ;;ACHSDENSTATS
+26 ;;ACHSDENUNMET
