ACHSA7 ; IHS/ITSC/PMF - ENTER DOCUMENTS (8/8)-(CONFIRM & RECORD) ; [ 01/18/2005 11:51 AM ]
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**1,11,12**;JUN 11, 2001
;;ACHS*3.1*1 keep 4 digit fiscal year
;ITSC/SET/JVK ACHS*3.1*11 MODIFIED FOR MEDICARE PROVIDER INFO
;ITSC/SET/JVK ACHS*3.1*12 MODIFIED FOR DHHS CONTRACT INFO
;
A1 ;
K ACHSDIEN
S ACHSORDN="",ACHSODT=DT
;ITSC/SET/JVK ACHS*3.1*12 ASK PROCUREMRNT INFO IF NOT 638 SITE
S ACHSCTYP=""
I $P(^ACHSF(DUZ(2),0),U,8)'="Y" D CNTRCT
;ITSC/SET/JVK END CHANGES
D ^ACHSAV ;DISPLAY DOCUMENT INFORMATION TO CONFIRM
S Y=$$DIR^XBDIR("Y","Is This Correct ","NO","","","",1)
I $D(DTOUT) D END Q
;ITSC/SET/JVK ACHS*3.1*12 THIS IS A Y/N COMMENT OUT BELOW
;G A1:$D(DUOUT)
I 'Y S ACHSAFLG=1 G A1A^ACHSA ;RESUME ENTRY OF DOCUMENT ASKING FOR FISCAL YEAR
D ERRCHK
I $D(ACHSOUT) D END S ACHSOUT=1 Q
D SB1 ;GO GET THE NEXT ACHSDIEN
; AND CREATE THE ENTRY
I $D(ACHSCNC) S ACHSAFLG=1 G A1A^ACHSA
W *7,!!," Document # ",ACHSORDN," Recorded",!!
D ACT^ACHSACT(ACHSDIEN,$$NOW^XLFDT,"<INITIAL>") ;RECORD ACTION ON
; DOCUMENT. IN THIS
; CASE CREATE ONE
LOCK
I $G(ACHSREF) D STAT^ACHSBMC("A") D AUTH^ACHSBMC
;IN THE RCIS REFERRAL FILE
D LAD^ACHSVPS(ACHSPROV,DT) ;UPDATE 'LAST AUTH DATE' IN VENDOR FILE
END ;
K ACHSREF,ACHSREFT,N
D END^ACHSA ;KILL VARS
Q
;
SB1 ;
S ACHS("CHK")=1
D SBAENT^ACHSUUP ;Update Current Advice of Allowance
;and Total Obligated FYTD
S ACHS("CHK")=0
I $D(ACHSCNC) D END S ACHSCNC=1 Q ;SOME. IS WRONG SET FLAG AGAIN?????
;
S ACHSDOCR=U_DT_U_$S($D(ACHSBLKF):1,$D(ACHSSLOC):2,1:0)_U_ACHSTYP_U_ACHSCONP_U_ACHSCAN_U_ACHSSCC_U_ACHSPROV_U_U_ACHSOBJC_U_U_"0"_U_ACHSCOPT
;
;12/3/01 pmf keep the four digit fiscal year as well as the one digit ACHS*3.1*1
;S ACHSDOCR=ACHSDOCR_U_$E(ACHSACFY,4)_U_U_U_ACHSDEST_U_DUZ_U_ACHSDCR_U_ACHSPATF_U_ACHSHRN_U_$G(DFN)_U_ACHSAGRP_U_U_ACHSDRG ; ACHS*3.1*1
S ACHSDOCR=ACHSDOCR_U_$E(ACHSACFY,4)_U_U_U_ACHSDEST_U_DUZ_U_ACHSDCR_U_ACHSPATF_U_ACHSHRN_U_$G(DFN)_U_ACHSAGRP_U_U_ACHSDRG_U_U_ACHSACFY ; ACHS*3.1*1
;
S ACHSTRAN=DT_U_"I"_U_$G(DFN)_U_ACHSESDO
;
;TRY AND LOCK DOCUMENT FILE IF CANNOT SET FLAG AND QUIT
I '$$LOCK^ACHS("^ACHSF(DUZ(2),""D"",0)","+") W !!,*7,"CHS FACILITY FILE IN USE BY ANOTHER PROCESS.",$$DIR^XBDIR("E") S ACHSCNC="" Q
;
;AGAIN HE BYPASSES FILEMAN AND MANUALLY SETS THE NEW RECORD
;THIS CAN BE REPLACED WITH FILEMAN CALL ??????
S:'$D(^ACHSF(DUZ(2),"D",0)) ^ACHSF(DUZ(2),"D",0)=$$ZEROTH^ACHS(9002080,100)
S ACHSDIEN=+$P($G(^ACHSF(DUZ(2),"D",0)),U,3)
;
EIN S ACHSDIEN=ACHSDIEN+1
I $D(^ACHSF(DUZ(2),"D",ACHSDIEN)) G EIN ;IEN IS IN USE. TRY AGAIN
;
D CKB^ACHSUUP ;CHECK BALANCES
;
I $D(ACHSCNC) Q ;IF BALANCES OUT OF SYNC CANCEL
;
S $P(^ACHSF(DUZ(2),"D",0),U,3)=ACHSDIEN ;LAST ASSIGNED IEN
;ADD ONE TO TOTAL ENTRIES
S $P(^ACHSF(DUZ(2),"D",0),U,4)=$P($G(^ACHSF(DUZ(2),"D",0)),U,4)+1
;
I '$$LOCK^ACHS("^ACHSF(DUZ(2),""D"",0)","-") W $$DIR^XBDIR("E") S ACHSCNC="" Q
I '$$LOCK^ACHS("^ACHSF(DUZ(2),""D"",ACHSDIEN)","+") W $$DIR^XBDIR("E") S ACHSCNC="" Q
S ^ACHSF(DUZ(2),"D",ACHSDIEN,0)=ACHSDOCR
S ^ACHSF(DUZ(2),"D","B","1"_$E(ACHSACFY,4)_ACHSACN,ACHSDIEN)=""
S $P(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U)=ACHSACN
25 ; Fields 25, 26, 26.01
;ITSC/SET/JVK ACHS*3.1*11 ADD NEW FIELD 26.02
;S ^ACHSF(DUZ(2),"D",ACHSDIEN,1)=$G(ACHSESDA)_U_$G(ACHSDES)_U_$G(ACHSPAN)
S ^ACHSF(DUZ(2),"D",ACHSDIEN,1)=$G(ACHSESDA)_U_$G(ACHSDES)_U_$G(ACHSPAN)_U_$G(ACHSMPP)
50 ;
I ACHSTYP=3,ACHSHON]"" S ^ACHSF(DUZ(2),"D",ACHSDIEN,2)=ACHSHON
;ITSC/SET/JVK ACHS*3.1*12
I $D(ACHSCAT) S $P(^ACHSF(DUZ(2),"D",ACHSDIEN,2),U,9)=ACHSCAT
75 ;
S ^ACHSF(DUZ(2),"D",ACHSDIEN,3)=ACHSFDT_U_ACHSTDT_$S((ACHSTYP=2)!$D(ACHSBLKF)!$D(ACHSSLOC):"",1:U_U_U_ACHSRPHY_U_ACHSRMPC_U_$P(ACHSRCOI,U)_U_ACHSRALR)
S $P(^ACHSF(DUZ(2),"D",ACHSDIEN,3),U,9)=ACHSEDOS
S $P(^ACHSF(DUZ(2),"D",ACHSDIEN,3),U,10)=ACHSREFT
S ^ACHSF(DUZ(2),"ES",ACHSEDOS,ACHSDIEN)=""
84 ;
I $D(ACHSRDX) D
. S:'$D(^ACHSF(DUZ(2),"D",ACHSDIEN,4,0)) ^ACHSF(DUZ(2),"D",ACHSDIEN,4,0)=$$ZEROTH^ACHS(9002080,100,84)
. F ACHS=1:1 Q:'$D(ACHSRDX(ACHS)) S DIC="^ACHSF("_DUZ(2)_",""D"","_ACHSDIEN_",4,",DIC(0)="",DA(2)=DUZ(2),DA(1)=ACHSDIEN,X=+ACHSRDX(ACHS) K DO,DD D FILE^DICN
;
85 ;
I $G(ACHSRDXN)]"" S ^ACHSF(DUZ(2),"D",ACHSDIEN,5)=ACHSRDXN
86 ;
I $D(ACHSRPX) D
. S:'$D(^ACHSF(DUZ(2),"D",ACHSDIEN,6,0)) ^ACHSF(DUZ(2),"D",ACHSDIEN,6,0)=$$ZEROTH^ACHS(9002080,100,86)
. F ACHS=1:1 Q:'$D(ACHSRPX(ACHS)) S DIC="^ACHSF("_DUZ(2)_",""D"","_ACHSDIEN_",6,",DIC(0)="",DA(2)=DUZ(2),DA(1)=ACHSDIEN,X=ACHSRPX(ACHS) K DO,DD D FILE^DICN
.Q
87 ;
I $G(ACHSRPXN)]"" S ^ACHSF(DUZ(2),"D",ACHSDIEN,7)=ACHSRPXN
I '$D(ACHSBLKF),'$D(ACHSSLOC) S ACHS("DX")=4,ACHS("PX")=6 D CDRG^ACHSPAM
;
;MANUALLY SET TRANSACTION RECORD ??????? BYPASSES FILEMAN
S:'$D(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",0)) ^ACHSF(DUZ(2),"D",ACHSDIEN,"T",0)=$$ZEROTH^ACHS(9002080,100,100)
S Y=$G(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",0))
SBD1 ;
S M=$P(Y,U,3)+1,$P(Y,U,3)=M,$P(Y,U,4)=M
G SBD1:$D(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",M))
S ^ACHSF(DUZ(2),"D",ACHSDIEN,"T",0)=Y,^ACHSF(DUZ(2),"D",ACHSDIEN,"T",M,0)=ACHSTRAN
S $P(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",M,0),U,11)=DUZ
S:$D(DFN) ^ACHSF(DUZ(2),"PB",DFN,ACHSDIEN,M)=""
S ^ACHSF(DUZ(2),"TB",DT,"I",ACHSDIEN,M)=""
S:$D(ACHSPROV) ^ACHSF(DUZ(2),"VB",ACHSPROV,ACHSDIEN,M)=""
I $D(ACHSBLKF)!($D(ACHSSLOC)) S ^ACHSF(DUZ(2),"D",ACHSDIEN,"BT")=ACHSBLT
S ACHSTIEN=M
;
D SBAENT^ACHSUUP ;Update Current Advice of Allowance
;and Total Obligated FYTD
;
I $D(ACHSCNC) D SBKILL Q ;IF SOMETHING WRONG WITH BALANCES CANCEL SETS
;
D SBQ^ACHSUUP ;Place document in print list
Q
;
SBKILL ;
K ^ACHSF(DUZ(2),"D",ACHSDIEN)
S X=$P($G(^ACHSF(DUZ(2),"D",0)),U,3) ;NEEDS RE-EVAL BIG TIME??????
S $P(^ACHSF(DUZ(2),"D",0),U,3)=X-1 ;LAST ENTRY USED. NOT
;NECESSARILY -1 ??????
S $P(^ACHSAF(DUZ(2),"D",0),U,4)=X-1 ;NUMBER OF ENTRIES
I $D(^ACHS(9,DUZ(2),"FY",ACHSACFY,"C")) D
.S ^ACHS(9,DUZ(2),"FY",ACHSACFY,"C")=$G(^ACHS(9,DUZ(2),"FY",ACHSACFY,"C"))-1
;MAJOR LOGIC ERROR FOR
;TYPE SEQUENCE FIELDS
;??????
K ^ACHSF(DUZ(2),"ES",ACHSEDOS,ACHSDIEN) ;THE FOLLOWING MANUALLY
;KILL THE X-REFS ??????
K ^ACHSF(DUZ(2),"PB",ACHSDIEN,ACHSTIEN)
K ^ACHSF(DUZ(2),"TB",DT,"I",ACHSDIEN,ACHSTIEN)
K ^ACHSF(DUZ(2),"VB",ACHSPROV,ACHSDIEN,ACHSTIEN)
K ^ACHSF(DUZ(2),"D","B",ACHSORDN)
Q
;
ERRCHK ;
K ACHSOUT
I '$D(ACHSHRN)!'$D(DFN) G ERRCHK1
I (+ACHSHRN)'=(+$$HRN^ACHS(DFN,ACHSPATF)) D
. W !!,*7,*7,"HEALTH RECORD NUMBER MISMATCH. NOTIFY PROGRAMMER IMMEDIATELY."
. W !,"ACHSHRN=",ACHSHRN," PATIENT RECORD #=",$$HRN^ACHS(DFN,ACHSPATF)," PATIENT FACILITY=",$P($G(^DIC(4,ACHSPATF,0)),U),!!!
. D RTRN^ACHS
;
ERRCHK1 ;
I '$$LOCK^ACHS("^ACHS(9,DUZ(2),""FY"",ACHSACFY,""C"")","+") G ERREND
S ACHSACN=$G(^ACHS(9,DUZ(2),"FY",ACHSACFY,"C"))
S ACHSACN=ACHSACN+1
S ACHSACN("NO")=ACHSACN
S ACHSACN=$E("00000",1,5-$L(ACHSACN))_ACHSACN
S ACHSORDN=$E(ACHSACFY,4)_"-"_$E("000",1,3-$L(ACHSFC))_ACHSFC_"-"_ACHSACN
S ACHSACN1="1"_$E(ACHSACFY,4)_ACHSACN
I '$D(^ACHSF(DUZ(2),"D","B",ACHSACN1)) D Q
. S ^ACHS(9,DUZ(2),"FY",ACHSACFY,"C")=ACHSACN("NO")
. I '$$LOCK^ACHS("^ACHS(9,DUZ(2),""FY"",ACHSACFY,""C"")","-")
;
;
W *7,*7,!!?25,"ABORTED!!",!?3,"Document number ALREADY EXISTS. Cannot issue DUPLICATE DOCUMENT NUMBERS",!?20,"Please notify your site manager!"
ERREND ;
W !
D RTRN^ACHS ;PRESS RETURN TO CONT.
LOCK ;UNLOCK EVERYTHING
S ACHSOUT=1
Q
;
CNTRCT ;
K DIR
S DIR(0)="P^9002068.1:EMZ"
S DIR("??")="^D DISCAT^ACHSA7"
S DIR("A")="Enter Contract Action Type"
D ^DIR
I Y="^",$D(DUOUT) W !,"Contract Action Type Required!",!,"Enter ?? for help.",! D CNTRCT
S ACHSCTYP=$P(Y,U),ACHSCAT=ACHSCTYP
DISCAT ;EP - From call to DIR
W !
S %=0
F S %=$O(^DD(9002068.1,.01,21,%)) Q:'% W !,$G(^DD(9002068.1,.01,21,%,0)) I $G(^DD(9002068.1,.01,21,%+1,0))[" - " Q:'$$DIR^XBDIR("E","Press RETURN...")
Q
ACHSA7 ; IHS/ITSC/PMF - ENTER DOCUMENTS (8/8)-(CONFIRM & RECORD) ; [ 01/18/2005 11:51 AM ]
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**1,11,12**;JUN 11, 2001
+2 ;;ACHS*3.1*1 keep 4 digit fiscal year
+3 ;ITSC/SET/JVK ACHS*3.1*11 MODIFIED FOR MEDICARE PROVIDER INFO
+4 ;ITSC/SET/JVK ACHS*3.1*12 MODIFIED FOR DHHS CONTRACT INFO
+5 ;
A1 ;
+1 KILL ACHSDIEN
+2 SET ACHSORDN=""
SET ACHSODT=DT
+3 ;ITSC/SET/JVK ACHS*3.1*12 ASK PROCUREMRNT INFO IF NOT 638 SITE
+4 SET ACHSCTYP=""
+5 IF $PIECE(^ACHSF(DUZ(2),0),U,8)'="Y"
DO CNTRCT
+6 ;ITSC/SET/JVK END CHANGES
+7 ;DISPLAY DOCUMENT INFORMATION TO CONFIRM
DO ^ACHSAV
+8 SET Y=$$DIR^XBDIR("Y","Is This Correct ","NO","","","",1)
+9 IF $DATA(DTOUT)
DO END
QUIT
+10 ;ITSC/SET/JVK ACHS*3.1*12 THIS IS A Y/N COMMENT OUT BELOW
+11 ;G A1:$D(DUOUT)
+12 ;RESUME ENTRY OF DOCUMENT ASKING FOR FISCAL YEAR
IF 'Y
SET ACHSAFLG=1
GOTO A1A^ACHSA
+13 DO ERRCHK
+14 IF $DATA(ACHSOUT)
DO END
SET ACHSOUT=1
QUIT
+15 ;GO GET THE NEXT ACHSDIEN
DO SB1
+16 ; AND CREATE THE ENTRY
+17 IF $DATA(ACHSCNC)
SET ACHSAFLG=1
GOTO A1A^ACHSA
+18 WRITE *7,!!," Document # ",ACHSORDN," Recorded",!!
+19 ;RECORD ACTION ON
DO ACT^ACHSACT(ACHSDIEN,$$NOW^XLFDT,"<INITIAL>")
+20 ; DOCUMENT. IN THIS
+21 ; CASE CREATE ONE
+22 LOCK
+23 IF $GET(ACHSREF)
DO STAT^ACHSBMC("A")
DO AUTH^ACHSBMC
+24 ;IN THE RCIS REFERRAL FILE
+25 ;UPDATE 'LAST AUTH DATE' IN VENDOR FILE
DO LAD^ACHSVPS(ACHSPROV,DT)
END ;
+1 KILL ACHSREF,ACHSREFT,N
+2 ;KILL VARS
DO END^ACHSA
+3 QUIT
+4 ;
SB1 ;
+1 SET ACHS("CHK")=1
+2 ;Update Current Advice of Allowance
DO SBAENT^ACHSUUP
+3 ;and Total Obligated FYTD
+4 SET ACHS("CHK")=0
+5 ;SOME. IS WRONG SET FLAG AGAIN?????
IF $DATA(ACHSCNC)
DO END
SET ACHSCNC=1
QUIT
+6 ;
+7 SET ACHSDOCR=U_DT_U_$SELECT($DATA(ACHSBLKF):1,$DATA(ACHSSLOC):2,1:0)_U_ACHSTYP_U_ACHSCONP_U_ACHSCAN_U_ACHSSCC_U_ACHSPROV_U_U_ACHSOBJC_U_U_"0"_U_ACHSCOPT
+8 ;
+9 ;12/3/01 pmf keep the four digit fiscal year as well as the one digit ACHS*3.1*1
+10 ;S ACHSDOCR=ACHSDOCR_U_$E(ACHSACFY,4)_U_U_U_ACHSDEST_U_DUZ_U_ACHSDCR_U_ACHSPATF_U_ACHSHRN_U_$G(DFN)_U_ACHSAGRP_U_U_ACHSDRG ; ACHS*3.1*1
+11 ; ACHS*3.1*1
SET ACHSDOCR=ACHSDOCR_U_$EXTRACT(ACHSACFY,4)_U_U_U_ACHSDEST_U_DUZ_U_ACHSDCR_U_ACHSPATF_U_ACHSHRN_U_$GET(DFN)_U_ACHSAGRP_U_U_ACHSDRG_U_U_ACHSACFY
+12 ;
+13 SET ACHSTRAN=DT_U_"I"_U_$GET(DFN)_U_ACHSESDO
+14 ;
+15 ;TRY AND LOCK DOCUMENT FILE IF CANNOT SET FLAG AND QUIT
+16 IF '$$LOCK^ACHS("^ACHSF(DUZ(2),""D"",0)","+")
WRITE !!,*7,"CHS FACILITY FILE IN USE BY ANOTHER PROCESS.",$$DIR^XBDIR("E")
SET ACHSCNC=""
QUIT
+17 ;
+18 ;AGAIN HE BYPASSES FILEMAN AND MANUALLY SETS THE NEW RECORD
+19 ;THIS CAN BE REPLACED WITH FILEMAN CALL ??????
+20 IF '$DATA(^ACHSF(DUZ(2),"D",0))
SET ^ACHSF(DUZ(2),"D",0)=$$ZEROTH^ACHS(9002080,100)
+21 SET ACHSDIEN=+$PIECE($GET(^ACHSF(DUZ(2),"D",0)),U,3)
+22 ;
EIN SET ACHSDIEN=ACHSDIEN+1
+1 ;IEN IS IN USE. TRY AGAIN
IF $DATA(^ACHSF(DUZ(2),"D",ACHSDIEN))
GOTO EIN
+2 ;
+3 ;CHECK BALANCES
DO CKB^ACHSUUP
+4 ;
+5 ;IF BALANCES OUT OF SYNC CANCEL
IF $DATA(ACHSCNC)
QUIT
+6 ;
+7 ;LAST ASSIGNED IEN
SET $PIECE(^ACHSF(DUZ(2),"D",0),U,3)=ACHSDIEN
+8 ;ADD ONE TO TOTAL ENTRIES
+9 SET $PIECE(^ACHSF(DUZ(2),"D",0),U,4)=$PIECE($GET(^ACHSF(DUZ(2),"D",0)),U,4)+1
+10 ;
+11 IF '$$LOCK^ACHS("^ACHSF(DUZ(2),""D"",0)","-")
WRITE $$DIR^XBDIR("E")
SET ACHSCNC=""
QUIT
+12 IF '$$LOCK^ACHS("^ACHSF(DUZ(2),""D"",ACHSDIEN)","+")
WRITE $$DIR^XBDIR("E")
SET ACHSCNC=""
QUIT
+13 SET ^ACHSF(DUZ(2),"D",ACHSDIEN,0)=ACHSDOCR
+14 SET ^ACHSF(DUZ(2),"D","B","1"_$EXTRACT(ACHSACFY,4)_ACHSACN,ACHSDIEN)=""
+15 SET $PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U)=ACHSACN
25 ; Fields 25, 26, 26.01
+1 ;ITSC/SET/JVK ACHS*3.1*11 ADD NEW FIELD 26.02
+2 ;S ^ACHSF(DUZ(2),"D",ACHSDIEN,1)=$G(ACHSESDA)_U_$G(ACHSDES)_U_$G(ACHSPAN)
+3 SET ^ACHSF(DUZ(2),"D",ACHSDIEN,1)=$GET(ACHSESDA)_U_$GET(ACHSDES)_U_$GET(ACHSPAN)_U_$GET(ACHSMPP)
50 ;
+1 IF ACHSTYP=3
IF ACHSHON]""
SET ^ACHSF(DUZ(2),"D",ACHSDIEN,2)=ACHSHON
+2 ;ITSC/SET/JVK ACHS*3.1*12
+3 IF $DATA(ACHSCAT)
SET $PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,2),U,9)=ACHSCAT
75 ;
+1 SET ^ACHSF(DUZ(2),"D",ACHSDIEN,3)=ACHSFDT_U_ACHSTDT_$SELECT((ACHSTYP=2)!$DATA(ACHSBLKF)!$DATA(ACHSSLOC):"",1:U_U_U_ACHSRPHY_U_ACHSRMPC_U_$PIECE(ACHSRCOI,U)_U_ACHSRALR)
+2 SET $PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,3),U,9)=ACHSEDOS
+3 SET $PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,3),U,10)=ACHSREFT
+4 SET ^ACHSF(DUZ(2),"ES",ACHSEDOS,ACHSDIEN)=""
84 ;
+1 IF $DATA(ACHSRDX)
Begin DoDot:1
+2 IF '$DATA(^ACHSF(DUZ(2),"D",ACHSDIEN,4,0))
SET ^ACHSF(DUZ(2),"D",ACHSDIEN,4,0)=$$ZEROTH^ACHS(9002080,100,84)
+3 FOR ACHS=1:1
IF '$DATA(ACHSRDX(ACHS))
QUIT
SET DIC="^ACHSF("_DUZ(2)_",""D"","_ACHSDIEN_",4,"
SET DIC(0)=""
SET DA(2)=DUZ(2)
SET DA(1)=ACHSDIEN
SET X=+ACHSRDX(ACHS)
KILL DO,DD
DO FILE^DICN
End DoDot:1
+4 ;
85 ;
+1 IF $GET(ACHSRDXN)]""
SET ^ACHSF(DUZ(2),"D",ACHSDIEN,5)=ACHSRDXN
86 ;
+1 IF $DATA(ACHSRPX)
Begin DoDot:1
+2 IF '$DATA(^ACHSF(DUZ(2),"D",ACHSDIEN,6,0))
SET ^ACHSF(DUZ(2),"D",ACHSDIEN,6,0)=$$ZEROTH^ACHS(9002080,100,86)
+3 FOR ACHS=1:1
IF '$DATA(ACHSRPX(ACHS))
QUIT
SET DIC="^ACHSF("_DUZ(2)_",""D"","_ACHSDIEN_",6,"
SET DIC(0)=""
SET DA(2)=DUZ(2)
SET DA(1)=ACHSDIEN
SET X=ACHSRPX(ACHS)
KILL DO,DD
DO FILE^DICN
+4 QUIT
End DoDot:1
87 ;
+1 IF $GET(ACHSRPXN)]""
SET ^ACHSF(DUZ(2),"D",ACHSDIEN,7)=ACHSRPXN
+2 IF '$DATA(ACHSBLKF)
IF '$DATA(ACHSSLOC)
SET ACHS("DX")=4
SET ACHS("PX")=6
DO CDRG^ACHSPAM
+3 ;
+4 ;MANUALLY SET TRANSACTION RECORD ??????? BYPASSES FILEMAN
+5 IF '$DATA(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",0))
SET ^ACHSF(DUZ(2),"D",ACHSDIEN,"T",0)=$$ZEROTH^ACHS(9002080,100,100)
+6 SET Y=$GET(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",0))
SBD1 ;
+1 SET M=$PIECE(Y,U,3)+1
SET $PIECE(Y,U,3)=M
SET $PIECE(Y,U,4)=M
+2 IF $DATA(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",M))
GOTO SBD1
+3 SET ^ACHSF(DUZ(2),"D",ACHSDIEN,"T",0)=Y
SET ^ACHSF(DUZ(2),"D",ACHSDIEN,"T",M,0)=ACHSTRAN
+4 SET $PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",M,0),U,11)=DUZ
+5 IF $DATA(DFN)
SET ^ACHSF(DUZ(2),"PB",DFN,ACHSDIEN,M)=""
+6 SET ^ACHSF(DUZ(2),"TB",DT,"I",ACHSDIEN,M)=""
+7 IF $DATA(ACHSPROV)
SET ^ACHSF(DUZ(2),"VB",ACHSPROV,ACHSDIEN,M)=""
+8 IF $DATA(ACHSBLKF)!($DATA(ACHSSLOC))
SET ^ACHSF(DUZ(2),"D",ACHSDIEN,"BT")=ACHSBLT
+9 SET ACHSTIEN=M
+10 ;
+11 ;Update Current Advice of Allowance
DO SBAENT^ACHSUUP
+12 ;and Total Obligated FYTD
+13 ;
+14 ;IF SOMETHING WRONG WITH BALANCES CANCEL SETS
IF $DATA(ACHSCNC)
DO SBKILL
QUIT
+15 ;
+16 ;Place document in print list
DO SBQ^ACHSUUP
+17 QUIT
+18 ;
SBKILL ;
+1 KILL ^ACHSF(DUZ(2),"D",ACHSDIEN)
+2 ;NEEDS RE-EVAL BIG TIME??????
SET X=$PIECE($GET(^ACHSF(DUZ(2),"D",0)),U,3)
+3 ;LAST ENTRY USED. NOT
SET $PIECE(^ACHSF(DUZ(2),"D",0),U,3)=X-1
+4 ;NECESSARILY -1 ??????
+5 ;NUMBER OF ENTRIES
SET $PIECE(^ACHSAF(DUZ(2),"D",0),U,4)=X-1
+6 IF $DATA(^ACHS(9,DUZ(2),"FY",ACHSACFY,"C"))
Begin DoDot:1
+7 SET ^ACHS(9,DUZ(2),"FY",ACHSACFY,"C")=$GET(^ACHS(9,DUZ(2),"FY",ACHSACFY,"C"))-1
End DoDot:1
+8 ;MAJOR LOGIC ERROR FOR
+9 ;TYPE SEQUENCE FIELDS
+10 ;??????
+11 ;THE FOLLOWING MANUALLY
KILL ^ACHSF(DUZ(2),"ES",ACHSEDOS,ACHSDIEN)
+12 ;KILL THE X-REFS ??????
+13 KILL ^ACHSF(DUZ(2),"PB",ACHSDIEN,ACHSTIEN)
+14 KILL ^ACHSF(DUZ(2),"TB",DT,"I",ACHSDIEN,ACHSTIEN)
+15 KILL ^ACHSF(DUZ(2),"VB",ACHSPROV,ACHSDIEN,ACHSTIEN)
+16 KILL ^ACHSF(DUZ(2),"D","B",ACHSORDN)
+17 QUIT
+18 ;
ERRCHK ;
+1 KILL ACHSOUT
+2 IF '$DATA(ACHSHRN)!'$DATA(DFN)
GOTO ERRCHK1
+3 IF (+ACHSHRN)'=(+$$HRN^ACHS(DFN,ACHSPATF))
Begin DoDot:1
+4 WRITE !!,*7,*7,"HEALTH RECORD NUMBER MISMATCH. NOTIFY PROGRAMMER IMMEDIATELY."
+5 WRITE !,"ACHSHRN=",ACHSHRN," PATIENT RECORD #=",$$HRN^ACHS(DFN,ACHSPATF)," PATIENT FACILITY=",$PIECE($GET(^DIC(4,ACHSPATF,0)),U),!!!
+6 DO RTRN^ACHS
End DoDot:1
+7 ;
ERRCHK1 ;
+1 IF '$$LOCK^ACHS("^ACHS(9,DUZ(2),""FY"",ACHSACFY,""C"")","+")
GOTO ERREND
+2 SET ACHSACN=$GET(^ACHS(9,DUZ(2),"FY",ACHSACFY,"C"))
+3 SET ACHSACN=ACHSACN+1
+4 SET ACHSACN("NO")=ACHSACN
+5 SET ACHSACN=$EXTRACT("00000",1,5-$LENGTH(ACHSACN))_ACHSACN
+6 SET ACHSORDN=$EXTRACT(ACHSACFY,4)_"-"_$EXTRACT("000",1,3-$LENGTH(ACHSFC))_ACHSFC_"-"_ACHSACN
+7 SET ACHSACN1="1"_$EXTRACT(ACHSACFY,4)_ACHSACN
+8 IF '$DATA(^ACHSF(DUZ(2),"D","B",ACHSACN1))
Begin DoDot:1
+9 SET ^ACHS(9,DUZ(2),"FY",ACHSACFY,"C")=ACHSACN("NO")
+10 IF '$$LOCK^ACHS("^ACHS(9,DUZ(2),""FY"",ACHSACFY,""C"")","-")
End DoDot:1
QUIT
+11 ;
+12 ;
+13 WRITE *7,*7,!!?25,"ABORTED!!",!?3,"Document number ALREADY EXISTS. Cannot issue DUPLICATE DOCUMENT NUMBERS",!?20,"Please notify your site manager!"
ERREND ;
+1 WRITE !
+2 ;PRESS RETURN TO CONT.
DO RTRN^ACHS
+3 ;UNLOCK EVERYTHING
LOCK
+4 SET ACHSOUT=1
+5 QUIT
+6 ;
CNTRCT ;
+1 KILL DIR
+2 SET DIR(0)="P^9002068.1:EMZ"
+3 SET DIR("??")="^D DISCAT^ACHSA7"
+4 SET DIR("A")="Enter Contract Action Type"
+5 DO ^DIR
+6 IF Y="^"
IF $DATA(DUOUT)
WRITE !,"Contract Action Type Required!",!,"Enter ?? for help.",!
DO CNTRCT
+7 SET ACHSCTYP=$PIECE(Y,U)
SET ACHSCAT=ACHSCTYP
DISCAT ;EP - From call to DIR
+1 WRITE !
+2 SET %=0
+3 FOR
SET %=$ORDER(^DD(9002068.1,.01,21,%))
IF '%
QUIT
WRITE !,$GET(^DD(9002068.1,.01,21,%,0))
IF $GET(^DD(9002068.1,.01,21,%+1,0))[" - "
IF '$$DIR^XBDIR("E","Press RETURN...")
QUIT
+4 QUIT