BAREV184 ; IHS/SD/LSL - ENVIRONMENT CHECK V1.8 PATCH 4; 05/08/2008
;;1.8;IHS ACCOUNTS RECEIVABLE;**1,2,3,4**;APR 27,2007
;
I '$G(DUZ) D Q
. W !,"DUZ UNDEFINED OR 0."
. D SORRY(2)
;
I '$L($G(DUZ(0))) D Q
. W !,"DUZ(0) UNDEFINED OR NULL."
. D SORRY(2)
;
;BAR*1.8*4 -- ONLY
;ALL SESSIONS MUST BE TRANSPORTED BEFORE INSTALL OF PATCH 4
S BAROK=1
;D ADDDIS ;ADD DEFAULT (#1504) UFMS DISPLAY DATE LIMIT
D TASK(DUZ(2),.BAROK)
I 'BAROK D Q
. W !!,*7,*7
. W $$CJ^XLFSTR("There are sessions that have not been transmitted",IOM)
. W !,$$CJ^XLFSTR("Please give the A/R cashiers the above list",IOM)
. W !,$$CJ^XLFSTR("Cannot proceed until all sessions are transmitted",IOM)
. D SORRY(2)
;
S X=$P(^VA(200,DUZ,0),U) ; User's name
W !!,$$CJ^XLFSTR("Hello, "_$P(X,",",2)_" "_$P(X,","),IOM)
W !!,$$CJ^XLFSTR("Checking Environment for "_$P($T(+2),";",4)_" V "_$P($T(+2),";",3),IOM)
;
N BARXU
S BARXU=$$INSTALLD("XU","8.0",1011) ;RLT ; Find current Kernel version and patch
I $P(BARXU,"*",2)<8 S BARXU=0
I $P(BARXU,"*",3)'=1 S BARXU=0 ;RLT
W !,$$CJ^XLFSTR("Need at least XU v8.0 Patch 1011..... "_$S(BARXU=0:"NOT ",1:"")_"Present",IOM)
I BARXU=0 D SORRY(2)
;
I $$VCHK("DI","21.0",2) ; FileMan V21.0
;
N BARXB
S BARXB=$$INSTALLD("XB","3.0",11) ;RLT ; Find current IHS utilities version and patch
I $P(BARXB,"*",2)<3 S BARXB=0
I $P(BARXU,"*",3)'=1 S BARXU=0 ;RLT
W !,$$CJ^XLFSTR("Need at least XB v3.0 Patch 11..... "_$S(BARXB=0:"NOT ",1:"")_"Present",IOM)
I BARXB=0 D SORRY(2)
;
I $$VCHK("BAR","1.8",2) ; Accounts Receivable V1.8
;
N BARABM
S BARABM=$$INSTALLD("ABM","2.5",13)
I $P(BARABM,"*",2)<2.5 S BARABM=0
I $P(BARABM,"*",3)'=1 S BARABM=0
W !,$$CJ^XLFSTR("Need at least Third Party Billing v2.5 Patch 13..... "_$S(BARABM=0:"NOT ",1:"")_"Present",IOM)
I BARABM=0 D SORRY(2)
;
;
N DA,DIC
S X="BAR"
S DIC="^DIC(9.4,"
S DIC(0)=""
S D="C"
D IX^DIC
I Y<0,$D(^DIC(9.4,"C","BAR")) D
. W !!,*7,*7,$$CJ^XLFSTR("You Have More Than One Entry In The",IOM)
. W !,$$CJ^XLFSTR("PACKAGE File with an ""BAR"" prefix.",IOM)
. W !,$$CJ^XLFSTR("One entry needs to be deleted.",IOM)
. D SORRY(2)
. Q
;
;LETS DOUBLE CHECK - MAKE SURE THEY SAVE THE GLOBALS OFF
;DONE IF UPDATING A/R TABLES
;I '$G(XPDQUIT) D
;.W !!!,$$CJ^XLFSTR("IMPORTANT: PLEASE MAKE SURE YOU SAVE THE FOLLOWING GLOBALS TO DISK?",IOM)
;.W !,$$CJ^XLFSTR("USE ^%GOGEN TO SAVE ^BAR(90052.01",IOM)
;.W !,$$CJ^XLFSTR("USE ^%GO TO SAVE ^BARTBL",IOM)
;
I $G(XPDQUIT) W !,$$CJ^XLFSTR("FIX IT! Before Proceeding.",IOM),!!,*7,*7,*7 Q
;
W !!,$$CJ^XLFSTR("ENVIRONMENT OK.",IOM)
D HELP^XBHELP("INTROE","BAREV184")
;
I $G(XPDENV)=1 D
. ; The following line prevents the "Disable Options..." and "Move
. ; Routines..." questions from being asked during the install.
. S (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0
. D HELP^XBHELP("INTROI","BAREV181")
. Q
;
I '$$DIR^XBDIR("E","","","","","",1) D SORRY(2)
Q
; ********************************************************************
SORRY(X) ;
KILL DIFQ
S XPDQUIT=X
W *7,!,$$CJ^XLFSTR("Sorry....FIX IT!",IOM)
Q
; ********************************************************************
VCHK(BARPRE,BARVER,BARQUIT) ; Check versions needed.
;
N BARV
S BARV=$$VERSION^XPDUTL(BARPRE)
W !,$$CJ^XLFSTR("Need at least "_BARPRE_" v "_BARVER_"....."_BARPRE_" v "_BARV_" Present",IOM)
I BARV<BARVER KILL DIFQ S XPDQUIT=BARQUIT D SORRY(BARQUIT) Q 0
Q 1
; ********************************************************************
INSTALLD(BARNM,BARVR,BARPT) ;EP ;RLT
; RLT - 04/05/05 - Per Don Jackson, modified this tag to use
; PATCH^XPDUTL. Removed the reverse $O, problem
; with XU patch numbers. VA (lower than 1000) and
; IHS patch numers (1000 and higher) not loaded
; in numerical order. No longer
; verifies that a lower version did not get
; reinstalled over a higher version.
N BARVNUM,BARPATCH
;1 get current version
S BARVNUM=$$VERSION^XPDUTL(BARNM)
I '+BARVNUM Q 0
;2 is needed patch loaded
S BARPATCH=$$PATCH^XPDUTL(BARNM_"*"_BARVR_"*"_BARPT)
I '+BARPATCH Q 0
Q BARNM_"*"_BARVNUM_"*"_BARPATCH
;
POST ;EP - POST INSTALL OF ZISH ENTRIES AND QUEING OF BIZTALK TASK
D STUFFDCM ;Stuff too long target id into
D FIXADJ3 ;FIX A/R EDI STND CLAIM ADJ REASONS STANDARD ADJUSTMENT CODE 3
; BAD ENTRY IN FIELD .03 (14;17) IM21683,IM23712
D AWODT ;CHANGE THE AWO EXPIRATION DATE
D ADWO ;ADD NEW WRITE OFF ENTRY IN BARTBL AT 916 SO IT DOESNOT GET OVERWRITTEN BY
; NEW ENTRIES IN PATCH 2
D EDIHIPAA ;EDIT "HIPAA 835 v4010" ENTRY IN A/R EDI TRANSPORT FILE
;
;set default value for field #22 in A/R COLLECTION POINT file
D COLPOINT
;
D ADDZISH ;ADD ZISH SEND PARAMETER ENTRIES FOR UFMS
Q
TASK(SAFEDUZ2,BAROK) ;EP - FOR PATCH 4 ONLY
;
K ^BARBOB("BARZ")
CKSESS ;
; Session status can be: O OPEN
; RC RECONCILED
; RV REVIEWED/APPROVED
; T TRANSMITTED
; RT RETRANSMITTED
K BAR
N BARLOC,BARST,BARUDUZ,BAR
S DUZ(2)=0
F S DUZ(2)=$O(^BARSESS(DUZ(2))) Q:'DUZ(2) D
.K ^BARSESS(DUZ(2),"NS") ;CLEAN OUT NOT SENT BUCKET
.Q:'$$IHS^BARUFUT(DUZ(2))
.S BARLOC=$P(^AUTTLOC(DUZ(2),0),U,2)
.S BARST=0
.F S BARST=$O(^BARSESS(DUZ(2),"C",BARST)) Q:BARST="" D
..Q:BARST["TRANSMIT" ;DON'T WANT (RE)TRANSMITTED
..S BARUDUZ=0
..F S BARUDUZ=$O(^BARSESS(DUZ(2),"C",BARST,BARUDUZ)) Q:'BARUDUZ D
...D LOOP(BARUDUZ,BARST)
I '$D(BAR) Q
D WRT
S BAROK=0
S DUZ(2)=SAFEDUZ2
Q
LOOP(UDUZ,STAT) ; - GET DATA FROM SESSION LEVEL
N SESSID,ERASTAT,CURSTAT,STATDATE,POSTING
S CASHIER=$E($P($G(^VA(200,UDUZ,0)),U),1,17)
S SESSID=0
F S SESSID=$O(^BARSESS(DUZ(2),"C",STAT,UDUZ,SESSID)) Q:SESSID="" D
.S IENS=SESSID_","_UDUZ_","
.S SESSDT=$$GET1^DIQ(90057.11,IENS,.01,"I")
.I SESSDT<3071001 Q ;IGNORE PRE-UFMS SESSIONS
.S CURSTAT=$$GET1^DIQ(90057.11,IENS,.02,"E")
.S STATDATE=$$GET1^DIQ(90057.11,IENS,.03,"E")
.S ERASTAT=$E($$GET1^DIQ(90057.11,IENS,.04,"E"))
.S POSTING=$$STILPOST^BARUFUT1(UDUZ)
.S Y=STATDATE X ^DD("DD") S STATDATE=Y
.S BAR(CASHIER,BARLOC,STAT,SESSID)=""
Q
WRT ;
W !!?25,"OPEN SESSIONS LIST FOR: "
W !,"CASHIER",?22,"LOCATION",?45,"STATUS",?65,"SESSION ID",!
N A,B,C,D
S A=""
F S A=$O(BAR(A)) Q:A="" D ;CASHIER
.S B=0
.F S B=$O(BAR(A,B)) Q:B="" D ;DUZ(2)
..S C=0
..F S C=$O(BAR(A,B,C)) Q:C="" D ;STATUS
...S D=0
...W A,?19,$E(B,1,20),?40,$E(C,1,20)
...F S D=$O(BAR(A,B,C,D)) Q:'D D ;SESSION ID
....W ?62,D,!
Q
ADDDIS ;EP -
K DIE,DR,DIC,DIE,DIR,DA
;S DR="1504////^S X=""T-1W"";1505////30"""
S X1=3071001
S X2=DT
D ^%DTC
S BARDT=X
S DUZ2=1
F S DUZ2=$O(^BAR(90052.06,DUZ2)) Q:'DUZ2 D
.S DA(1)=DUZ2
.S DA=0
.F S DA=$O(^BAR(90052.06,DUZ2,DA)) Q:'DA D
..S DR="1504////T"_BARDT
..S DR=DR_";1505////30""" ;IHS/SD/TPF BAR*1.8*4 IM26189
..I '$$IHS^BARUFUT(DA) S DR=DR_";1502////1;1503////1" ;FOR NON-IHS SITES
..S DIE="^BAR(90052.06,"_DA(1)_","
..D ^DIE
Q
COLPOINT ;EP -
K DIE,DR,DIC,DIE,DIR,DA
S DR="22////^S X=1"
S DUZ2=1
N BART ;BAR*1.8*4
F S DUZ2=$O(^BAR(90051.02,DUZ2)) Q:'DUZ2 D
.S DA(1)=DUZ2
.S DA=0
.F S DA=$O(^BAR(90051.02,DUZ2,DA)) Q:'DA D
..S BART=$P($G(^BAR(90051.02,DUZ2,DA,0)),U,22) ;BAR*1.8*4
..Q:BART'="" ;DON'T OVERWRITE ;BAR*1.8*4
..S DIE="^BAR(90051.02,"_DA(1)_","
..D ^DIE
Q
ADWO ; EP
N ADWO
S ADWO="^BARTBL(916,0)"
S @ADWO="AUTO WRITE-OFF 2007^3^WO"
S DIK="^BARTBL(" D IXALL^DIK
Q
AWODT ;EP -
K DIR,DIE,DIC,DA,DR
S DR="15////^S X=3070525"
S DUZ2=1
F S DUZ2=$O(^BAR(90052.06,DUZ2)) Q:'DUZ2 D
.S DIE="^BAR(90052.06,"_DUZ2_","
.S DA=DUZ2
.D ^DIE
Q
EDIHIPAA ;EP - EDIT HIPAA TRANSPORT ENTRY
N TRANIEN
S TRANIEN=$O(^BAREDI("1T","B","HIPAA 835 v4010",""))
I 'TRANIEN D Q
.W !,$$CJ^XLFSTR("CANNOT FIND HIPAA 835 v4010 ENTRY!!",IOM)
.W !,$$CJ^XLFSTR("INFORM THE HELP DESK IMMEDIATELY!!",IOM)
;BEGIN UPDATING FIELDS
;
;EDIT SEGMENT 2-080.B-N1
;IDENTIFICATION CODE QUALIFIER
K DIE,DIC,DA,DR,DIR
S DA(2)=TRANIEN
S DA(1)=15
S DA=3
S DIE="^BAREDI(""1T"","_DA(2)_",10,"_DA(1)_",10,"
S BARVAL="VICQ"
S DR=".08///^S X=BARVAL"
D ^DIE
;
;IDENTIFICATION CODE
K DIE,DIC,DA,DR,DIR
S DA(2)=TRANIEN
S DA(1)=15
S DA=4
S DIE="^BAREDI(""1T"","_DA(2)_",10,"_DA(1)_",10,"
S BARVAL="VIC"
S DR=".08///^S X=BARVAL"
D ^DIE
;
;REFERENCE ID QUALIFIER
K DIE,DIC,DA,DR,DIR
S DA(2)=TRANIEN
S DA(1)=18
S DA=1
S DIE="^BAREDI(""1T"","_DA(2)_",10,"_DA(1)_",10,"
S BARVAL="VREFBIQ"
S DR=".08///^S X=BARVAL"
D ^DIE
;
;REFERENCE IDENTIFICATION
K DIE,DIC,DA,DR,DIR
S DA(2)=TRANIEN
S DA(1)=18
S DA=2
S DIE="^BAREDI(""1T"","_DA(2)_",10,"_DA(1)_",10,"
S BARVAL="VREFBID"
S DR=".08///^S X=BARVAL"
D ^DIE
;
;VARIABLE PROCESSING
K DIE,DIC,DA,DR,DIR
S X="VREFBIQ"
S DA(1)=TRANIEN
S DIC(0)="L"
S DIC="^BAREDI(""1T"","_DA(1)_",70,"
D ^DIC
I +Y>0 D
.K DIE,DIC,DA,DR,DIR
.S DA=+Y
.S DA(1)=TRANIEN
.S DIE="^BAREDI(""1T"","_DA(1)_",70,"
.S BARVAL="VREFB|BAREDPA1"
.S DR=".02///^S X=BARVAL"
.D ^DIE
;
K DIE,DIC,DA,DR,DIR
S X="VREFBID"
S DA(1)=TRANIEN
S DIC(0)="L"
S DIC="^BAREDI(""1T"","_DA(1)_",70,"
D ^DIC
I +Y>0 D
.K DIE,DIC,DA,DR,DIR
.S DA=+Y
.S DA(1)=TRANIEN
.S DIE="^BAREDI(""1T"","_DA(1)_",70,"
.S BARVAL="VREFB|BAREDPA1"
.S DR=".02///^S X=BARVAL"
.D ^DIE
;
K DIE,DIC,DA,DR,DIR
S X="VIC"
S DA(1)=TRANIEN
S DIC(0)="L"
S DIC="^BAREDI(""1T"","_DA(1)_",70,"
D ^DIC
I +Y>0 D
.K DIE,DIC,DA,DR,DIR
.S DA=+Y
.S DA(1)=TRANIEN
.S DIE="^BAREDI(""1T"","_DA(1)_",70,"
.S BARVAL="VIC|BAREDPA1"
.S DR=".02///^S X=BARVAL"
.D ^DIE
Q
;
PRE ;EP - PRE INSTALL - DELETE OLD DATA IN TABLES
Q ;PER ADRIAN DO NOT UPDATE TABLES UNTIL HE STRAIGHTENS IT OUT. APPEARS OUR TABLES ARE NOT UPDATED??
;I AM NOT SURE WE KNOW WHAT ENTRIES THEY SHOULD HAVE.
;W !,"DELETING OLD TABLE DATA.."
;S IEN=0 F S IEN=$O(^BARTBL(IEN)) Q:IEN=""!(IEN>999) W "." K ^BARTBL(IEN)
Q
FIXADJ3 ;EP
K DIE,DIR,DR,DA,DIC
S DIE="^BARADJ("
S DA=3
S DR=".03///14;.04///27"
D ^DIE
Q
STUFFDCM ;
D BMES^XPDUTL("Updating Debt Collection Target ID in ZISH SEND PARAMETERS file....")
K DIC,DIE,DA,DR,DIR
S TARGETID="asdstgw.d1.na.DOMAIN.NAME"
F X="BAR DCM B","BAR DCM F" D
.S DIC="^%ZIB(9888888.93,"
.S DIC(0)=""
.D ^DIC
.Q:Y<0
.S DIE=DIC
.K DIC,DA,DR,DIR
.S DA=+Y
.S DR=".02////"_TARGETID
.D ^DIE
Q
ADDZISH ;EP - ADD ZISH ENTIRES TO 'ZISH SEND PARAMETERS' FILE
;ADD 'BAR UFMS B' BACKGROUND ENTRY
;ADD 'BAR UFMS F' FOREGROUND ENTRY
ADDF ;ADD FOREGROUND
;I $D(^%ZIB(9888888.93,"B","BAR UFMS F")) D
;IF ENTRY IS SET TO umftest THIS IS TEST SYSTEM - DO NOT UPDATE
I $D(^%ZIB(9888888.93,"B","BAR UFMS F")) D Q:$$GET1^DIQ(9888888.93,REC_",",.03)="ufmstest" ;BAR*1.8*4
.S REC=$O(^%ZIB(9888888.93,"B","BAR UFMS F",""))
.D BMES^XPDUTL("Found [BAR UFMS F] as a ZISH SEND PARAMETER entry")
D BMES^XPDUTL("Adding [BAR UFMS F] as a ZISH SEND PARAMETER entry")
K DIC,DIE,DA,DR,DIR
S DIC="^%ZIB(9888888.93,"
S DIC(0)="L"
S X="BAR UFMS F"
D ^DIC
I +Y<0 W !,"UNABLE TO ADD ZISH PARAMETER ENTRY. TRY MANUALLY!!" Q
K DIC,DIE,DA,DR,DIR,DD,DO,DINUM
S DIE="^%ZIB(9888888.93,"
S DA=+Y
S USERNAME="ufmsuser"
S PASSWORD="vjrsshn9"
S SENDCMD="sendto"
S TYPE="F"
;S TARGETIP="quovadx-ie.DOMAIN.NAME"
S TARGETIP="quovadx-ie" ;BAR*1.8*4
S ARGS="-i -u -a"
S DR=".02///^S X=TARGETIP"
S DR=DR_";.03///^S X=USERNAME"
S DR=DR_";.04////^S X=PASSWORD"
S DR=DR_";.06///^S X=ARGS"
S DR=DR_";.07///^S X=TYPE"
S DR=DR_";.08///^S X=SENDCMD"
D ^DIE
K DIC,DIE,DA,DR,DIR
ADDB ;ADD BACKGROUND
;I $D(^%ZIB(9888888.93,"B","BAR UFMS B")) D
I $D(^%ZIB(9888888.93,"B","BAR UFMS B")) D Q:$$GET1^DIQ(9888888.93,REC_",",.03)="ufmstest" ;BAR*1.8*4
.S REC=$O(^%ZIB(9888888.93,"B","BAR UFMS B","")) ;BAR*1.8*4
.D BMES^XPDUTL("Found [BAR UFMS B] as a ZISH SEND PARAMETER entry")
D BMES^XPDUTL("Adding [BAR UFMS B] as a ZISH SEND PARAMETER entry")
K DIC,DIE,DA,DR,DIR
S DIC="^%ZIB(9888888.93,"
S DIC(0)="L"
S X="BAR UFMS B"
D ^DIC
I +Y<0 D BMES^XPDUTL("UNABLE TO ADD ZISH PARAMETER ENTRY. TRY MANUALLY!!")
K DIC,DIE,DA,DR,DIR,DD,DO,DINUM
S DIE="^%ZIB(9888888.93,"
S DA=+Y
S USERNAME="ufmsuser"
S PASSWORD="vjrsshn9"
S SENDCMD="sendto"
S TYPE="B"
;S TARGETIP="quovadx-ie.DOMAIN.NAME"
S TARGETIP="quovadx-ie" ;BAR*1.8*4
S ARGS="-i -u -a"
S DR=".02///^S X=TARGETIP"
S DR=DR_";.03///^S X=USERNAME"
S DR=DR_";.04////^S X=PASSWORD"
S DR=DR_";.06///^S X=ARGS"
S DR=DR_";.07///^S X=TYPE"
S DR=DR_";.08///^S X=SENDCMD"
D ^DIE
K DIC,DIE,DA,DR,DIR
Q
; ********************************************************************
INTROE ; Intro text during KIDS Environment check.
;;This distribution Modifies Accounts Receivable containing previous patch
;;modifications for version 1.8. This patch is cumulative.
;;
;;###
;;
;
INTROI ; Intro text during KIDS Install.
;;If you run interactively, results will be displayed on your screen,
;;and recorded in the entry in the INSTALL file.
;;If you queue to TaskMan, remember not to Q to the HOME device.
;;###
BAREV184 ; IHS/SD/LSL - ENVIRONMENT CHECK V1.8 PATCH 4; 05/08/2008
+1 ;;1.8;IHS ACCOUNTS RECEIVABLE;**1,2,3,4**;APR 27,2007
+2 ;
+3 IF '$GET(DUZ)
Begin DoDot:1
+4 WRITE !,"DUZ UNDEFINED OR 0."
+5 DO SORRY(2)
End DoDot:1
QUIT
+6 ;
+7 IF '$LENGTH($GET(DUZ(0)))
Begin DoDot:1
+8 WRITE !,"DUZ(0) UNDEFINED OR NULL."
+9 DO SORRY(2)
End DoDot:1
QUIT
+10 ;
+11 ;BAR*1.8*4 -- ONLY
+12 ;ALL SESSIONS MUST BE TRANSPORTED BEFORE INSTALL OF PATCH 4
+13 SET BAROK=1
+14 ;D ADDDIS ;ADD DEFAULT (#1504) UFMS DISPLAY DATE LIMIT
+15 DO TASK(DUZ(2),.BAROK)
+16 IF 'BAROK
Begin DoDot:1
+17 WRITE !!,*7,*7
+18 WRITE $$CJ^XLFSTR("There are sessions that have not been transmitted",IOM)
+19 WRITE !,$$CJ^XLFSTR("Please give the A/R cashiers the above list",IOM)
+20 WRITE !,$$CJ^XLFSTR("Cannot proceed until all sessions are transmitted",IOM)
+21 DO SORRY(2)
End DoDot:1
QUIT
+22 ;
+23 ; User's name
SET X=$PIECE(^VA(200,DUZ,0),U)
+24 WRITE !!,$$CJ^XLFSTR("Hello, "_$PIECE(X,",",2)_" "_$PIECE(X,","),IOM)
+25 WRITE !!,$$CJ^XLFSTR("Checking Environment for "_$PIECE($TEXT(+2),";",4)_" V "_$PIECE($TEXT(+2),";",3),IOM)
+26 ;
+27 NEW BARXU
+28 ;RLT ; Find current Kernel version and patch
SET BARXU=$$INSTALLD("XU","8.0",1011)
+29 IF $PIECE(BARXU,"*",2)<8
SET BARXU=0
+30 ;RLT
IF $PIECE(BARXU,"*",3)'=1
SET BARXU=0
+31 WRITE !,$$CJ^XLFSTR("Need at least XU v8.0 Patch 1011..... "_$SELECT(BARXU=0:"NOT ",1:"")_"Present",IOM)
+32 IF BARXU=0
DO SORRY(2)
+33 ;
+34 ; FileMan V21.0
IF $$VCHK("DI","21.0",2)
+35 ;
+36 NEW BARXB
+37 ;RLT ; Find current IHS utilities version and patch
SET BARXB=$$INSTALLD("XB","3.0",11)
+38 IF $PIECE(BARXB,"*",2)<3
SET BARXB=0
+39 ;RLT
IF $PIECE(BARXU,"*",3)'=1
SET BARXU=0
+40 WRITE !,$$CJ^XLFSTR("Need at least XB v3.0 Patch 11..... "_$SELECT(BARXB=0:"NOT ",1:"")_"Present",IOM)
+41 IF BARXB=0
DO SORRY(2)
+42 ;
+43 ; Accounts Receivable V1.8
IF $$VCHK("BAR","1.8",2)
+44 ;
+45 NEW BARABM
+46 SET BARABM=$$INSTALLD("ABM","2.5",13)
+47 IF $PIECE(BARABM,"*",2)<2.5
SET BARABM=0
+48 IF $PIECE(BARABM,"*",3)'=1
SET BARABM=0
+49 WRITE !,$$CJ^XLFSTR("Need at least Third Party Billing v2.5 Patch 13..... "_$SELECT(BARABM=0:"NOT ",1:"")_"Present",IOM)
+50 IF BARABM=0
DO SORRY(2)
+51 ;
+52 ;
+53 NEW DA,DIC
+54 SET X="BAR"
+55 SET DIC="^DIC(9.4,"
+56 SET DIC(0)=""
+57 SET D="C"
+58 DO IX^DIC
+59 IF Y<0
IF $DATA(^DIC(9.4,"C","BAR"))
Begin DoDot:1
+60 WRITE !!,*7,*7,$$CJ^XLFSTR("You Have More Than One Entry In The",IOM)
+61 WRITE !,$$CJ^XLFSTR("PACKAGE File with an ""BAR"" prefix.",IOM)
+62 WRITE !,$$CJ^XLFSTR("One entry needs to be deleted.",IOM)
+63 DO SORRY(2)
+64 QUIT
End DoDot:1
+65 ;
+66 ;LETS DOUBLE CHECK - MAKE SURE THEY SAVE THE GLOBALS OFF
+67 ;DONE IF UPDATING A/R TABLES
+68 ;I '$G(XPDQUIT) D
+69 ;.W !!!,$$CJ^XLFSTR("IMPORTANT: PLEASE MAKE SURE YOU SAVE THE FOLLOWING GLOBALS TO DISK?",IOM)
+70 ;.W !,$$CJ^XLFSTR("USE ^%GOGEN TO SAVE ^BAR(90052.01",IOM)
+71 ;.W !,$$CJ^XLFSTR("USE ^%GO TO SAVE ^BARTBL",IOM)
+72 ;
+73 IF $GET(XPDQUIT)
WRITE !,$$CJ^XLFSTR("FIX IT! Before Proceeding.",IOM),!!,*7,*7,*7
QUIT
+74 ;
+75 WRITE !!,$$CJ^XLFSTR("ENVIRONMENT OK.",IOM)
+76 DO HELP^XBHELP("INTROE","BAREV184")
+77 ;
+78 IF $GET(XPDENV)=1
Begin DoDot:1
+79 ; The following line prevents the "Disable Options..." and "Move
+80 ; Routines..." questions from being asked during the install.
+81 SET (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0
+82 DO HELP^XBHELP("INTROI","BAREV181")
+83 QUIT
End DoDot:1
+84 ;
+85 IF '$$DIR^XBDIR("E","","","","","",1)
DO SORRY(2)
+86 QUIT
+87 ; ********************************************************************
SORRY(X) ;
+1 KILL DIFQ
+2 SET XPDQUIT=X
+3 WRITE *7,!,$$CJ^XLFSTR("Sorry....FIX IT!",IOM)
+4 QUIT
+5 ; ********************************************************************
VCHK(BARPRE,BARVER,BARQUIT) ; Check versions needed.
+1 ;
+2 NEW BARV
+3 SET BARV=$$VERSION^XPDUTL(BARPRE)
+4 WRITE !,$$CJ^XLFSTR("Need at least "_BARPRE_" v "_BARVER_"....."_BARPRE_" v "_BARV_" Present",IOM)
+5 IF BARV<BARVER
KILL DIFQ
SET XPDQUIT=BARQUIT
DO SORRY(BARQUIT)
QUIT 0
+6 QUIT 1
+7 ; ********************************************************************
INSTALLD(BARNM,BARVR,BARPT) ;EP ;RLT
+1 ; RLT - 04/05/05 - Per Don Jackson, modified this tag to use
+2 ; PATCH^XPDUTL. Removed the reverse $O, problem
+3 ; with XU patch numbers. VA (lower than 1000) and
+4 ; IHS patch numers (1000 and higher) not loaded
+5 ; in numerical order. No longer
+6 ; verifies that a lower version did not get
+7 ; reinstalled over a higher version.
+8 NEW BARVNUM,BARPATCH
+9 ;1 get current version
+10 SET BARVNUM=$$VERSION^XPDUTL(BARNM)
+11 IF '+BARVNUM
QUIT 0
+12 ;2 is needed patch loaded
+13 SET BARPATCH=$$PATCH^XPDUTL(BARNM_"*"_BARVR_"*"_BARPT)
+14 IF '+BARPATCH
QUIT 0
+15 QUIT BARNM_"*"_BARVNUM_"*"_BARPATCH
+16 ;
POST ;EP - POST INSTALL OF ZISH ENTRIES AND QUEING OF BIZTALK TASK
+1 ;Stuff too long target id into
DO STUFFDCM
+2 ;FIX A/R EDI STND CLAIM ADJ REASONS STANDARD ADJUSTMENT CODE 3
DO FIXADJ3
+3 ; BAD ENTRY IN FIELD .03 (14;17) IM21683,IM23712
+4 ;CHANGE THE AWO EXPIRATION DATE
DO AWODT
+5 ;ADD NEW WRITE OFF ENTRY IN BARTBL AT 916 SO IT DOESNOT GET OVERWRITTEN BY
DO ADWO
+6 ; NEW ENTRIES IN PATCH 2
+7 ;EDIT "HIPAA 835 v4010" ENTRY IN A/R EDI TRANSPORT FILE
DO EDIHIPAA
+8 ;
+9 ;set default value for field #22 in A/R COLLECTION POINT file
+10 DO COLPOINT
+11 ;
+12 ;ADD ZISH SEND PARAMETER ENTRIES FOR UFMS
DO ADDZISH
+13 QUIT
TASK(SAFEDUZ2,BAROK) ;EP - FOR PATCH 4 ONLY
+1 ;
+2 KILL ^BARBOB("BARZ")
CKSESS ;
+1 ; Session status can be: O OPEN
+2 ; RC RECONCILED
+3 ; RV REVIEWED/APPROVED
+4 ; T TRANSMITTED
+5 ; RT RETRANSMITTED
+6 KILL BAR
+7 NEW BARLOC,BARST,BARUDUZ,BAR
+8 SET DUZ(2)=0
+9 FOR
SET DUZ(2)=$ORDER(^BARSESS(DUZ(2)))
IF 'DUZ(2)
QUIT
Begin DoDot:1
+10 ;CLEAN OUT NOT SENT BUCKET
KILL ^BARSESS(DUZ(2),"NS")
+11 IF '$$IHS^BARUFUT(DUZ(2))
QUIT
+12 SET BARLOC=$PIECE(^AUTTLOC(DUZ(2),0),U,2)
+13 SET BARST=0
+14 FOR
SET BARST=$ORDER(^BARSESS(DUZ(2),"C",BARST))
IF BARST=""
QUIT
Begin DoDot:2
+15 ;DON'T WANT (RE)TRANSMITTED
IF BARST["TRANSMIT"
QUIT
+16 SET BARUDUZ=0
+17 FOR
SET BARUDUZ=$ORDER(^BARSESS(DUZ(2),"C",BARST,BARUDUZ))
IF 'BARUDUZ
QUIT
Begin DoDot:3
+18 DO LOOP(BARUDUZ,BARST)
End DoDot:3
End DoDot:2
End DoDot:1
+19 IF '$DATA(BAR)
QUIT
+20 DO WRT
+21 SET BAROK=0
+22 SET DUZ(2)=SAFEDUZ2
+23 QUIT
LOOP(UDUZ,STAT) ; - GET DATA FROM SESSION LEVEL
+1 NEW SESSID,ERASTAT,CURSTAT,STATDATE,POSTING
+2 SET CASHIER=$EXTRACT($PIECE($GET(^VA(200,UDUZ,0)),U),1,17)
+3 SET SESSID=0
+4 FOR
SET SESSID=$ORDER(^BARSESS(DUZ(2),"C",STAT,UDUZ,SESSID))
IF SESSID=""
QUIT
Begin DoDot:1
+5 SET IENS=SESSID_","_UDUZ_","
+6 SET SESSDT=$$GET1^DIQ(90057.11,IENS,.01,"I")
+7 ;IGNORE PRE-UFMS SESSIONS
IF SESSDT<3071001
QUIT
+8 SET CURSTAT=$$GET1^DIQ(90057.11,IENS,.02,"E")
+9 SET STATDATE=$$GET1^DIQ(90057.11,IENS,.03,"E")
+10 SET ERASTAT=$EXTRACT($$GET1^DIQ(90057.11,IENS,.04,"E"))
+11 SET POSTING=$$STILPOST^BARUFUT1(UDUZ)
+12 SET Y=STATDATE
XECUTE ^DD("DD")
SET STATDATE=Y
+13 SET BAR(CASHIER,BARLOC,STAT,SESSID)=""
End DoDot:1
+14 QUIT
WRT ;
+1 WRITE !!?25,"OPEN SESSIONS LIST FOR: "
+2 WRITE !,"CASHIER",?22,"LOCATION",?45,"STATUS",?65,"SESSION ID",!
+3 NEW A,B,C,D
+4 SET A=""
+5 ;CASHIER
FOR
SET A=$ORDER(BAR(A))
IF A=""
QUIT
Begin DoDot:1
+6 SET B=0
+7 ;DUZ(2)
FOR
SET B=$ORDER(BAR(A,B))
IF B=""
QUIT
Begin DoDot:2
+8 SET C=0
+9 ;STATUS
FOR
SET C=$ORDER(BAR(A,B,C))
IF C=""
QUIT
Begin DoDot:3
+10 SET D=0
+11 WRITE A,?19,$EXTRACT(B,1,20),?40,$EXTRACT(C,1,20)
+12 ;SESSION ID
FOR
SET D=$ORDER(BAR(A,B,C,D))
IF 'D
QUIT
Begin DoDot:4
+13 WRITE ?62,D,!
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+14 QUIT
ADDDIS ;EP -
+1 KILL DIE,DR,DIC,DIE,DIR,DA
+2 ;S DR="1504////^S X=""T-1W"";1505////30"""
+3 SET X1=3071001
+4 SET X2=DT
+5 DO ^%DTC
+6 SET BARDT=X
+7 SET DUZ2=1
+8 FOR
SET DUZ2=$ORDER(^BAR(90052.06,DUZ2))
IF 'DUZ2
QUIT
Begin DoDot:1
+9 SET DA(1)=DUZ2
+10 SET DA=0
+11 FOR
SET DA=$ORDER(^BAR(90052.06,DUZ2,DA))
IF 'DA
QUIT
Begin DoDot:2
+12 SET DR="1504////T"_BARDT
+13 ;IHS/SD/TPF BAR*1.8*4 IM26189
SET DR=DR_";1505////30"""
+14 ;FOR NON-IHS SITES
IF '$$IHS^BARUFUT(DA)
SET DR=DR_";1502////1;1503////1"
+15 SET DIE="^BAR(90052.06,"_DA(1)_","
+16 DO ^DIE
End DoDot:2
End DoDot:1
+17 QUIT
COLPOINT ;EP -
+1 KILL DIE,DR,DIC,DIE,DIR,DA
+2 SET DR="22////^S X=1"
+3 SET DUZ2=1
+4 ;BAR*1.8*4
NEW BART
+5 FOR
SET DUZ2=$ORDER(^BAR(90051.02,DUZ2))
IF 'DUZ2
QUIT
Begin DoDot:1
+6 SET DA(1)=DUZ2
+7 SET DA=0
+8 FOR
SET DA=$ORDER(^BAR(90051.02,DUZ2,DA))
IF 'DA
QUIT
Begin DoDot:2
+9 ;BAR*1.8*4
SET BART=$PIECE($GET(^BAR(90051.02,DUZ2,DA,0)),U,22)
+10 ;DON'T OVERWRITE ;BAR*1.8*4
IF BART'=""
QUIT
+11 SET DIE="^BAR(90051.02,"_DA(1)_","
+12 DO ^DIE
End DoDot:2
End DoDot:1
+13 QUIT
ADWO ; EP
+1 NEW ADWO
+2 SET ADWO="^BARTBL(916,0)"
+3 SET @ADWO="AUTO WRITE-OFF 2007^3^WO"
+4 SET DIK="^BARTBL("
DO IXALL^DIK
+5 QUIT
AWODT ;EP -
+1 KILL DIR,DIE,DIC,DA,DR
+2 SET DR="15////^S X=3070525"
+3 SET DUZ2=1
+4 FOR
SET DUZ2=$ORDER(^BAR(90052.06,DUZ2))
IF 'DUZ2
QUIT
Begin DoDot:1
+5 SET DIE="^BAR(90052.06,"_DUZ2_","
+6 SET DA=DUZ2
+7 DO ^DIE
End DoDot:1
+8 QUIT
EDIHIPAA ;EP - EDIT HIPAA TRANSPORT ENTRY
+1 NEW TRANIEN
+2 SET TRANIEN=$ORDER(^BAREDI("1T","B","HIPAA 835 v4010",""))
+3 IF 'TRANIEN
Begin DoDot:1
+4 WRITE !,$$CJ^XLFSTR("CANNOT FIND HIPAA 835 v4010 ENTRY!!",IOM)
+5 WRITE !,$$CJ^XLFSTR("INFORM THE HELP DESK IMMEDIATELY!!",IOM)
End DoDot:1
QUIT
+6 ;BEGIN UPDATING FIELDS
+7 ;
+8 ;EDIT SEGMENT 2-080.B-N1
+9 ;IDENTIFICATION CODE QUALIFIER
+10 KILL DIE,DIC,DA,DR,DIR
+11 SET DA(2)=TRANIEN
+12 SET DA(1)=15
+13 SET DA=3
+14 SET DIE="^BAREDI(""1T"","_DA(2)_",10,"_DA(1)_",10,"
+15 SET BARVAL="VICQ"
+16 SET DR=".08///^S X=BARVAL"
+17 DO ^DIE
+18 ;
+19 ;IDENTIFICATION CODE
+20 KILL DIE,DIC,DA,DR,DIR
+21 SET DA(2)=TRANIEN
+22 SET DA(1)=15
+23 SET DA=4
+24 SET DIE="^BAREDI(""1T"","_DA(2)_",10,"_DA(1)_",10,"
+25 SET BARVAL="VIC"
+26 SET DR=".08///^S X=BARVAL"
+27 DO ^DIE
+28 ;
+29 ;REFERENCE ID QUALIFIER
+30 KILL DIE,DIC,DA,DR,DIR
+31 SET DA(2)=TRANIEN
+32 SET DA(1)=18
+33 SET DA=1
+34 SET DIE="^BAREDI(""1T"","_DA(2)_",10,"_DA(1)_",10,"
+35 SET BARVAL="VREFBIQ"
+36 SET DR=".08///^S X=BARVAL"
+37 DO ^DIE
+38 ;
+39 ;REFERENCE IDENTIFICATION
+40 KILL DIE,DIC,DA,DR,DIR
+41 SET DA(2)=TRANIEN
+42 SET DA(1)=18
+43 SET DA=2
+44 SET DIE="^BAREDI(""1T"","_DA(2)_",10,"_DA(1)_",10,"
+45 SET BARVAL="VREFBID"
+46 SET DR=".08///^S X=BARVAL"
+47 DO ^DIE
+48 ;
+49 ;VARIABLE PROCESSING
+50 KILL DIE,DIC,DA,DR,DIR
+51 SET X="VREFBIQ"
+52 SET DA(1)=TRANIEN
+53 SET DIC(0)="L"
+54 SET DIC="^BAREDI(""1T"","_DA(1)_",70,"
+55 DO ^DIC
+56 IF +Y>0
Begin DoDot:1
+57 KILL DIE,DIC,DA,DR,DIR
+58 SET DA=+Y
+59 SET DA(1)=TRANIEN
+60 SET DIE="^BAREDI(""1T"","_DA(1)_",70,"
+61 SET BARVAL="VREFB|BAREDPA1"
+62 SET DR=".02///^S X=BARVAL"
+63 DO ^DIE
End DoDot:1
+64 ;
+65 KILL DIE,DIC,DA,DR,DIR
+66 SET X="VREFBID"
+67 SET DA(1)=TRANIEN
+68 SET DIC(0)="L"
+69 SET DIC="^BAREDI(""1T"","_DA(1)_",70,"
+70 DO ^DIC
+71 IF +Y>0
Begin DoDot:1
+72 KILL DIE,DIC,DA,DR,DIR
+73 SET DA=+Y
+74 SET DA(1)=TRANIEN
+75 SET DIE="^BAREDI(""1T"","_DA(1)_",70,"
+76 SET BARVAL="VREFB|BAREDPA1"
+77 SET DR=".02///^S X=BARVAL"
+78 DO ^DIE
End DoDot:1
+79 ;
+80 KILL DIE,DIC,DA,DR,DIR
+81 SET X="VIC"
+82 SET DA(1)=TRANIEN
+83 SET DIC(0)="L"
+84 SET DIC="^BAREDI(""1T"","_DA(1)_",70,"
+85 DO ^DIC
+86 IF +Y>0
Begin DoDot:1
+87 KILL DIE,DIC,DA,DR,DIR
+88 SET DA=+Y
+89 SET DA(1)=TRANIEN
+90 SET DIE="^BAREDI(""1T"","_DA(1)_",70,"
+91 SET BARVAL="VIC|BAREDPA1"
+92 SET DR=".02///^S X=BARVAL"
+93 DO ^DIE
End DoDot:1
+94 QUIT
+95 ;
PRE ;EP - PRE INSTALL - DELETE OLD DATA IN TABLES
+1 ;PER ADRIAN DO NOT UPDATE TABLES UNTIL HE STRAIGHTENS IT OUT. APPEARS OUR TABLES ARE NOT UPDATED??
QUIT
+2 ;I AM NOT SURE WE KNOW WHAT ENTRIES THEY SHOULD HAVE.
+3 ;W !,"DELETING OLD TABLE DATA.."
+4 ;S IEN=0 F S IEN=$O(^BARTBL(IEN)) Q:IEN=""!(IEN>999) W "." K ^BARTBL(IEN)
+5 QUIT
FIXADJ3 ;EP
+1 KILL DIE,DIR,DR,DA,DIC
+2 SET DIE="^BARADJ("
+3 SET DA=3
+4 SET DR=".03///14;.04///27"
+5 DO ^DIE
+6 QUIT
STUFFDCM ;
+1 DO BMES^XPDUTL("Updating Debt Collection Target ID in ZISH SEND PARAMETERS file....")
+2 KILL DIC,DIE,DA,DR,DIR
+3 SET TARGETID="asdstgw.d1.na.DOMAIN.NAME"
+4 FOR X="BAR DCM B","BAR DCM F"
Begin DoDot:1
+5 SET DIC="^%ZIB(9888888.93,"
+6 SET DIC(0)=""
+7 DO ^DIC
+8 IF Y<0
QUIT
+9 SET DIE=DIC
+10 KILL DIC,DA,DR,DIR
+11 SET DA=+Y
+12 SET DR=".02////"_TARGETID
+13 DO ^DIE
End DoDot:1
+14 QUIT
ADDZISH ;EP - ADD ZISH ENTIRES TO 'ZISH SEND PARAMETERS' FILE
+1 ;ADD 'BAR UFMS B' BACKGROUND ENTRY
+2 ;ADD 'BAR UFMS F' FOREGROUND ENTRY
ADDF ;ADD FOREGROUND
+1 ;I $D(^%ZIB(9888888.93,"B","BAR UFMS F")) D
+2 ;IF ENTRY IS SET TO umftest THIS IS TEST SYSTEM - DO NOT UPDATE
+3 ;BAR*1.8*4
IF $DATA(^%ZIB(9888888.93,"B","BAR UFMS F"))
Begin DoDot:1
+4 SET REC=$ORDER(^%ZIB(9888888.93,"B","BAR UFMS F",""))
+5 DO BMES^XPDUTL("Found [BAR UFMS F] as a ZISH SEND PARAMETER entry")
End DoDot:1
IF $$GET1^DIQ(9888888.93,REC_",",.03)="ufmstest"
QUIT
+6 DO BMES^XPDUTL("Adding [BAR UFMS F] as a ZISH SEND PARAMETER entry")
+7 KILL DIC,DIE,DA,DR,DIR
+8 SET DIC="^%ZIB(9888888.93,"
+9 SET DIC(0)="L"
+10 SET X="BAR UFMS F"
+11 DO ^DIC
+12 IF +Y<0
WRITE !,"UNABLE TO ADD ZISH PARAMETER ENTRY. TRY MANUALLY!!"
QUIT
+13 KILL DIC,DIE,DA,DR,DIR,DD,DO,DINUM
+14 SET DIE="^%ZIB(9888888.93,"
+15 SET DA=+Y
+16 SET USERNAME="ufmsuser"
+17 SET PASSWORD="vjrsshn9"
+18 SET SENDCMD="sendto"
+19 SET TYPE="F"
+20 ;S TARGETIP="quovadx-ie.DOMAIN.NAME"
+21 ;BAR*1.8*4
SET TARGETIP="quovadx-ie"
+22 SET ARGS="-i -u -a"
+23 SET DR=".02///^S X=TARGETIP"
+24 SET DR=DR_";.03///^S X=USERNAME"
+25 SET DR=DR_";.04////^S X=PASSWORD"
+26 SET DR=DR_";.06///^S X=ARGS"
+27 SET DR=DR_";.07///^S X=TYPE"
+28 SET DR=DR_";.08///^S X=SENDCMD"
+29 DO ^DIE
+30 KILL DIC,DIE,DA,DR,DIR
ADDB ;ADD BACKGROUND
+1 ;I $D(^%ZIB(9888888.93,"B","BAR UFMS B")) D
+2 ;BAR*1.8*4
IF $DATA(^%ZIB(9888888.93,"B","BAR UFMS B"))
Begin DoDot:1
+3 ;BAR*1.8*4
SET REC=$ORDER(^%ZIB(9888888.93,"B","BAR UFMS B",""))
+4 DO BMES^XPDUTL("Found [BAR UFMS B] as a ZISH SEND PARAMETER entry")
End DoDot:1
IF $$GET1^DIQ(9888888.93,REC_",",.03)="ufmstest"
QUIT
+5 DO BMES^XPDUTL("Adding [BAR UFMS B] as a ZISH SEND PARAMETER entry")
+6 KILL DIC,DIE,DA,DR,DIR
+7 SET DIC="^%ZIB(9888888.93,"
+8 SET DIC(0)="L"
+9 SET X="BAR UFMS B"
+10 DO ^DIC
+11 IF +Y<0
DO BMES^XPDUTL("UNABLE TO ADD ZISH PARAMETER ENTRY. TRY MANUALLY!!")
+12 KILL DIC,DIE,DA,DR,DIR,DD,DO,DINUM
+13 SET DIE="^%ZIB(9888888.93,"
+14 SET DA=+Y
+15 SET USERNAME="ufmsuser"
+16 SET PASSWORD="vjrsshn9"
+17 SET SENDCMD="sendto"
+18 SET TYPE="B"
+19 ;S TARGETIP="quovadx-ie.DOMAIN.NAME"
+20 ;BAR*1.8*4
SET TARGETIP="quovadx-ie"
+21 SET ARGS="-i -u -a"
+22 SET DR=".02///^S X=TARGETIP"
+23 SET DR=DR_";.03///^S X=USERNAME"
+24 SET DR=DR_";.04////^S X=PASSWORD"
+25 SET DR=DR_";.06///^S X=ARGS"
+26 SET DR=DR_";.07///^S X=TYPE"
+27 SET DR=DR_";.08///^S X=SENDCMD"
+28 DO ^DIE
+29 KILL DIC,DIE,DA,DR,DIR
+30 QUIT
+31 ; ********************************************************************
INTROE ; Intro text during KIDS Environment check.
+1 ;;This distribution Modifies Accounts Receivable containing previous patch
+2 ;;modifications for version 1.8. This patch is cumulative.
+3 ;;
+4 ;;###
+5 ;;
+6 ;
INTROI ; Intro text during KIDS Install.
+1 ;;If you run interactively, results will be displayed on your screen,
+2 ;;and recorded in the entry in the INSTALL file.
+3 ;;If you queue to TaskMan, remember not to Q to the HOME device.
+4 ;;###
