Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ACHSA7

ACHSA7.m

Go to the documentation of this file.
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