ACHSRP2 ; IHS/ITSC/PMF - PRINT CHS FORMS - INIT NAMED VARS, CALL FORM ROUTINE ; [ 01/21/2005 3:50 PM ]
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**3,5,7,11,16**;JUNE 11,2001
;ACHS*3.1*3 correct display of date
;IHS/SET/GTH ACHS*3.1*5 12/06/2002 - Fix blank line, other formatting.
;ITSC/SET/JVK ACHS*3.1*7 10/28/2003 - Add electronic signature stuff
;ITSC/SET/JVK ACHS*3.1*11 9/16/2004 - Display Medicare Provider Info
;ACHS*3.1*16 10/26/2009 OIT.FCJ MULTIPLE COPIES FOR ZUNI
;
;IF NO DATA FOR DOCUMENT OR TRANSACTION QUIT (SEE ABOUT LETTING USER
;KNOW) OR RECORDING THIS SOMEHOW??????
I '$D(^ACHSF(DUZ(2),"D",ACHSDIEN,0))!'$D(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN,0)) D END Q
;
;
;DO INIT & REF IF USE UNIVERSAL FORM IS YES AND NOT DENTAL TYPE
;D KILLNULS ;LETS KILL ALL ARRAY VALUES SO WE DON'T CARRY THEM OVER
D INIT,REF:($$PARM^ACHS(2,16)="Y")&(ACHSTYP'=2)
D SB1^ACHSRP1
;
I $$PARM^ACHS(2,16)="Y",$P(^AUTTLOC(DUZ(2),0),U,10)=202501 F ACHSL=1:1:ACHSCPY-1 D ^ACHSRPU ;ACHS*3.1*16 IHS.OIT.FCJ CHANGED FOR ZUNI
I $$PARM^ACHS(2,16)="Y" D ^ACHSRPU ;UNIVERSAL FORM. ALL SITES SHOULD
;BE DOING THIS NOW
I $$PARM^ACHS(2,16)'="Y" D
.I ACHSTYPV'=2 D ^ACHSRP3 Q ;IF NOT DENTAL PRINT 43 & 64 FORMS
.D ^ACHSRP3D ;ELSE PRINT 57 DENTAL FORMS
;
;
I $D(ACHSRPNT) K ^TMP("ACHSRR",$J,DUZ(2),ACHSTYPV,ACHSDIEN,ACHSTIEN) D END Q ;??????????
LOCK +^ACHS(7,ACHS7DA):60 ;??????LETS THINK ABOUT WHY THIS IS LOCKED
;
;NOW THAT WE KNOW WE PRINTED A DOCUMENT LETS CREATE THE RECORD
S X=$G(^ACHS(7,ACHS7DA,"D",0))
S N=$P(X,U,3)+1 ;INCREMENT ENTRY
S M=$P(X,U,4)+1 ;INCREMENT LAST ENTRY USED
S ^ACHS(7,ACHS7DA,"D",N,0)=ACHSORDN_U_DUZ(2)_U_ACHSDIEN_U_ACHSTIEN
S ^ACHS(7,ACHS7DA,"D","B",ACHSORDN,N)=""
S ^ACHS(7,ACHS7DA,"D",0)=$P(X,U,1,2)_U_N_U_M
S ^ACHS(7,"P",DUZ(2),ACHSDIEN,ACHSTIEN,ACHS7DA,N)=""
LOCK -^ACHS(7,ACHS7DA):60
K ^ACHSF("PQ",DUZ(2),ACHSTYPV,ACHSDIEN,ACHSTIEN)
Q
END ;
K A,B,C,D,E,F,I,R,N,ACHSIPRM
;ITSC/SET/JVK ACHS*3.1*11 kill vars below
K ACHSMPP,ACHSDS,ACHSMPN
Q
;
INIT ;EP - Initialize local vars to existing document data.
;THIS ENTRY CALLED BY ACHSAJ,ACHSBUG3,ACHSPAM,ACHSUSC
;SET NOTFOUND VARIABLE TO UNDEFINED STRINGS
D KILLNULS
K ACHSNOTF
S $P(ACHSNOTF," --- "_U,30)=""
S ACHSDOC0=$G(^ACHSF(DUZ(2),"D",ACHSDIEN,0),ACHSNOTF) ;DOC NODE 0
S ACHSDOC1=$G(^ACHSF(DUZ(2),"D",ACHSDIEN,1),ACHSNOTF) ;DOC NODE 1
S ACHSDOC2=$G(^ACHSF(DUZ(2),"D",ACHSDIEN,2),ACHSNOTF) ;DOC NODE 2
S ACHSDOC3=$G(^ACHSF(DUZ(2),"D",ACHSDIEN,3),ACHSNOTF) ;DOC NODE 3
S ACHSTRA0=$G(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN,0),ACHSNOTF) ;TRANS NODE 0
;
;contract pointer is not printed, so it does not get set via UNDEF
S ACHSCONP=$P(ACHSDOC0,U,5) ;CONTRACT PTR
;ITSC/SET/JVK ACHS*3.1*11 Set Medicare Prov. Pointer
S ACHSMPP=$P(ACHSDOC1,U,4) ;MEDICARE PROV. PTR.
;
S ACHSCAN=$$UNDEF($P(ACHSDOC0,U,6)) ;COMMON ACCT #
S ACHSSCC=$$UNDEF($P(ACHSDOC0,U,7)) ;OBJECT CLASS.
S ACHSOBJC=$$UNDEF($P(ACHSDOC0,U,10)) ;VENDOR CHRG. EST.
S S=$$UNDEF($P(ACHSDOC0,U,14)) ;FISCAL YEAR
S ACHSTYP=$$UNDEF($P(ACHSDOC0,U,4)) ;TYPE OF SERVICE
S ACHSCOPT=$$UNDEF($P(ACHSDOC0,U,13)) ;COMMENTS OPTIONAL
S ACHSODT=$$UNDEF($P(ACHSDOC0,U,2)) ;ORDER DATE
S ACHSBLAN=$$UNDEF($P(ACHSDOC0,U,3)) ;BLANKET ORDER?
S ACHSDEST=$$UNDEF($P(ACHSDOC0,U,17)) ;DOCUMENT DEST.
S ACHSDCR=$$UNDEF($P(ACHSDOC0,U,19)) ;DOCUMENT CONTROL REGISTER
;ITSC/SET/JVK ACHS*3.1*7 ADDED NEXT FOUR LINES
S ACHSESIG=$$GET1^DIQ(200,$$UNDEF($P(ACHSDOC0,U,24)),.01) ;E SIG
S Y=$$UNDEF($P(ACHSDOC0,U,28)) X ^DD("DD") S ACHSEDTE=Y ;E DATE
S ACHSASIG=$$GET1^DIQ(200,$$UNDEF($P(ACHSDOC0,U,29)),.01) ;AUTH SIG
S Y=$$UNDEF($P(ACHSDOC0,U,30)) X ^DD("DD") S ACHSADTE=Y ;A DATE
;
;PROVIDER INFO
S ACHSPROV=$$UNDEF($P(ACHSDOC0,U,8)) ;PROVIDER PTR
S ACHSAGRP=$$UNDEF($P(ACHSDOC0,U,23)) ;VENDOR AGREE. PTR
S ACHSPR18=""
S:ACHSAGRP'="" ACHSPR18=$G(^AUTTVNDR(ACHSPROV,18,ACHSAGRP,0),ACHSNOTF)
S ACHSMRTO=$$UNDEF($P(ACHSPR18,U,5)) ;MEDICARE RATE OUTPATIENT
S ACHSMRTI=$$UNDEF($P(ACHSPR18,U,4)) ;MEDICARE RATE INPATIENT
;ITSC/SET/JVK ACHS*3.1*11 - nxt. three lines
S:ACHSMPP'="" ACHSMPN=$P($G(^AUTTVNDR(ACHSPROV,"MP",ACHSMPP,0)),U)
S:ACHSMPP'="" ACHSDS=$P($G(^AUTTVNDR(ACHSPROV,"MP",ACHSMPP,0)),U,2)
S:ACHSMPP'="" ACHSDS=$$EXTSET^XBFUNC(9999999.112303,2,ACHSDS)
;
;
S ACHSORDN=S_"-"_ACHSFC_"-"_$P(ACHSDOC0,U) ;FULL ORDER #
;
;FACILITY INFO
S ACHSPATF=$$UNDEF($P(ACHSDOC0,U,20)) ;PATIENT FACILITY PTR
S ACHSLOC0=$G(^AUTTLOC(ACHSPATF,0),ACHSNOTF) ;LOCATION NODE 0
;
;TRANSACTION INFO
S ACHSDOS=$P(ACHSTRA0,U,10) ;DATE OF SERVICE
S ACHSTYPE=$P(ACHSTRA0,U,2) ;TRANSACTION TYPE
S ACHSLCA=$P(ACHSTRA0,U,7) ;CANCEL NUMBER
;
;GET SUPPLEMENT NUMBER
S ACHSSF=$S($P(ACHSTRA0,U,6)="":"",1:"S"_$P(ACHSTRA0,U,6))
;
;IF NO SUPP NUM. MAYBE BE CANCEL NUMBER
I ACHSSF="" S ACHSSF=$S($P(ACHSTRA0,U,7)="":"",1:"C"_$P(ACHSTRA0,U,7))
;
S E(7)=ACHSODT
I ACHSTYPE="S" D ;TRANSACTION TYPE SET IN INIT^ACHSRP2
.S E(11)=E(7) ;MOVE ORDER DATE TO E(11)
.S X=$P(ACHSTRA0,U) ;TRANSACTION DATE
.I X'=" --- " S E(7)=$E(X,4,5)_"-"_$E(X,6,7)_"-"_$E(X,2,3)
.E S E(7)=X
;
;NEXT LINE GETS 'REFERRAL TYPE (DENTAL ONLY)' FROM DOCUMENT SUBFILE
;AND 'REFERRAL TYPE (NOT USED)' FROM TRANSACTION SUBFILE
S ACHSREFT=$E($P(ACHSTRA0,U,11)_$P(ACHSDOC3,U,10))
;
K ACHSBLKF
;
;IF THIS IS A BLANKET ORDER GET BLANKET ORDER TYPE
I ACHSBLAN S ACHSBLKF="",ACHSBLT=$G(^ACHSF(DUZ(2),"D",ACHSDIEN,"BT"))
;ITSC/SET/JVK ACHS*3.1*7 COMMENT OUT BELOW ADD ACHSSISIG,ACHSSIG
;S ACHSSIG=$P($G(^ACHSF(DUZ(2),"P")),U,ACHSTYP) ;?????????
S ACHSISIG=$$GET1^DIQ(200,$$UNDEF($P(ACHSDOC0,U,18)),.01) ;DOC INITIATOR
S ACHSSIG=$$GET1^DIQ(200,$$UNDEF($P(ACHSDOC0,U,18)),20.3) ;TITLE
S ACHSESDO=$$UNDEF($P(ACHSTRA0,U,4)) ;IHS PAYMENT AMOUNT
S DFN=$$UNDEF($P(ACHSTRA0,U,3)) ;PATIENT PTR
;
S (ACHSEDOS,ACHSFDT,ACHSTDT)=""
I ACHSTYP D
.S ACHSFDT=$$UNDEF($P(ACHSDOC3,U)) ;AUTH BEGINNING DATE
.S ACHSTDT=$P(ACHSDOC3,U,2)
. ;1/10/02 pmf that's not how you add days to a date
. ;I ACHSTYP=1,(ACHSTDT="") S ACHSTDT=$P(ACHSDOC3,U,1)+$P(ACHSDOC1,U,1) ; ACHS*3.1*3
. I ACHSTYP=1,(ACHSTDT="") N X,X1,X2 S X1=ACHSFDT,X2=$P(ACHSDOC1,U,1) D C^%DTC S ACHSTDT=X ; ACHS*3.1*3
. ;
.S ACHSTDT=$$UNDEF(ACHSTDT) ;AUTH ENDING DATE
.S ACHSEDOS=$$UNDEF($P(ACHSDOC3,U,9)) ;EST. DATE OF SERVICE
.S:ACHSEDOS="" ACHSEDOS=ACHSFDT ;
S ACHSESDA=$$UNDEF($P(ACHSDOC1,U)) ;ESTIMATED INPATIENT DAYS
; ;HOSPITAL TYPE ONLY????
S ACHSHON=$$UNDEF($P(ACHSDOC2,U)) ;HOSPITAL ORDER #
; ;DENTAL ONLY????
S ACHSDES=$$UNDEF($P(ACHSDOC1,U,2)) ;DESCRIPTION OF SERVICE
S A(7)=ACHSDES
D PRT^ACHSUDF ;GET PATIENT, FACILITY &
; ;INSURANCE INFO
Q
;RESET ARRAY VALUES TO NULL
KILLNULS ;
F ACHSX="A","B","C","D","E","F" F ACHSY=1:1:12 S ACHS=ACHSX_"("_ACHSY_")" S @(ACHS)=" --- "
Q
;
REF ; Set Referral Physician and Medical Priority into print vars.
Q:$D(ACHSBLKF) ;DON'T GET INFO IF BLANKET ORDER
S (ACHSDX,ACHSPX,X,N)=""
;
S ACHS200=$S($G(^DD(9002080.01,80,0))["VA(200,":1,1:0) ;FIX REF TO LOOK AT 80 INSTEAD OF 50
;
I $D(^ACHSF(DUZ(2),"D",ACHSDIEN,3)) D ;FIX THE REFERRAL PHYSICIAN DISPLAY PROBLEM
.S R(1)=$$UNDEF($P(ACHSDOC3,U,5)) ;REFERRING PHYSICIAN PTR
.;
.S R(2)=$$UNDEF($P(ACHSDOC3,U,6)) ;REFERRAL MEDICAL PRIORITY ;FIX THE REFERRAL PHYSICIAN DISPLAY PROBLEM
.;
.I ACHS200 S:R(1)>0 R(1)=$P($G(^VA(200,R(1),0)," --- "),U) ;FIX THE REFERRAL PHYSICIAN DISPLAY PROBLEM
.;IHS/SET/GTH ACHS*3.1*5 12/06/2002
.I 'ACHS200 D
..S ACHSREFP=$$UNDEF($P($G(^DIC(6,R(1),0)),U))
..S:+R(1)>0 R(1)=$$UNDEF($P($G(^DIC(16,ACHSREFP,0)),U)) ;FIX THE REFERRAL PHYSICIAN DISPLAY PROBLEM
. I R(2),R(2)["I" S R(2)=$$UNDEF($P($T(@R(2)),";;",2)) ;FIX THE REFERRAL PHYSICIAN DISPLAY PROBLEM
;
;
PROC ; Set Referral Procedure Narrative into print vars for regular Form.
I $$PARM^ACHS(2,16)="Y" G PROC1 ;IF PRINTING UNIVERSAL FORM
G:'$D(^ACHSF(DUZ(2),"D",ACHSDIEN,7)) DIAG
S ACHSPX=$G(^ACHSF(DUZ(2),"D",ACHSDIEN,7)) ;DOCUMENT 7 NODE
; ;REFERRAL PX NARRATIVE
I $L(ACHSPX)>190 S R("P",1)=$E(ACHSPX,1,22),N=23
I $L(ACHSPX)<190 S R("P",1)="",N=1
F X=2:1:5 S R("P",X)=$E(ACHSPX,N,N+37),N=N+38
DIAG ; Set Referral Diagnosis Narrative into print vars for regular Form.
G:'$D(^ACHSF(DUZ(2),"D",ACHSDIEN,5)) EXT
S ACHSDX=$G(^ACHSF(DUZ(2),"D",ACHSDIEN,5))
I $L(ACHSDX)>148 S R("D",1)=$E(ACHSDX,1,22),N=23
I $L(ACHSDX)<148 S R("D",1)="",N=1
F X=2:1:4 S R("D",X)=$E(ACHSDX,N,N+36),N=N+37
EXT ;
K ACHSDX,ACHSPX,X,N
Q
;
REFCOD ;
I ;;Emergent/Acutely Urg
II ;;Preventive Sevices
III ;;Prim/Sec Services
IV ;;Chr Tert/Exten Svc
;
;
PROC1 ; Set Referral Procedure Narrative into print vars for Universal Form.
G:'$D(^ACHSF(DUZ(2),"D",ACHSDIEN,7)) DIAG1 S ACHSPX=$G(^ACHSF(DUZ(2),"D",ACHSDIEN,7))
I $L(ACHSPX)>118 S R("P",1)=$E(ACHSPX,1,22),N=23
I $L(ACHSPX)<118 S R("P",1)="",N=1
F X=2:1:4 S R("P",X)=$E(ACHSPX,N,N+36),N=N+37
DIAG1 ; Set Referral Diagnosis Narrative into print vars for Universal Form.
G:'$D(^ACHSF(DUZ(2),"D",ACHSDIEN,5)) EXT1 S ACHSDX=$G(^ACHSF(DUZ(2),"D",ACHSDIEN,5))
I $L(ACHSDX)>72 S R("D",1)=$E(ACHSDX,1,22),N=23
I $L(ACHSDX)<72 S R("D",1)="",N=1
F X=2:1:3 S R("D",X)=$E(ACHSDX,N,N+36),N=N+37
EXT1 ;
K ACHSDX,ACHSPX,X,N
Q
;
;RETURN " --- " IF NULL
UNDEF(X) ;
I X="UNDEFINED"!(X="") Q " --- "
Q X
;
ACHSRP2 ; IHS/ITSC/PMF - PRINT CHS FORMS - INIT NAMED VARS, CALL FORM ROUTINE ; [ 01/21/2005 3:50 PM ]
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**3,5,7,11,16**;JUNE 11,2001
+2 ;ACHS*3.1*3 correct display of date
+3 ;IHS/SET/GTH ACHS*3.1*5 12/06/2002 - Fix blank line, other formatting.
+4 ;ITSC/SET/JVK ACHS*3.1*7 10/28/2003 - Add electronic signature stuff
+5 ;ITSC/SET/JVK ACHS*3.1*11 9/16/2004 - Display Medicare Provider Info
+6 ;ACHS*3.1*16 10/26/2009 OIT.FCJ MULTIPLE COPIES FOR ZUNI
+7 ;
+8 ;IF NO DATA FOR DOCUMENT OR TRANSACTION QUIT (SEE ABOUT LETTING USER
+9 ;KNOW) OR RECORDING THIS SOMEHOW??????
+10 IF '$DATA(^ACHSF(DUZ(2),"D",ACHSDIEN,0))!'$DATA(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN,0))
DO END
QUIT
+11 ;
+12 ;
+13 ;DO INIT & REF IF USE UNIVERSAL FORM IS YES AND NOT DENTAL TYPE
+14 ;D KILLNULS ;LETS KILL ALL ARRAY VALUES SO WE DON'T CARRY THEM OVER
+15 DO INIT
IF ($$PARM^ACHS(2,16)="Y")&(ACHSTYP'=2)
DO REF
+16 DO SB1^ACHSRP1
+17 ;
+18 ;ACHS*3.1*16 IHS.OIT.FCJ CHANGED FOR ZUNI
IF $$PARM^ACHS(2,16)="Y"
IF $PIECE(^AUTTLOC(DUZ(2),0),U,10)=202501
FOR ACHSL=1:1:ACHSCPY-1
DO ^ACHSRPU
+19 ;UNIVERSAL FORM. ALL SITES SHOULD
IF $$PARM^ACHS(2,16)="Y"
DO ^ACHSRPU
+20 ;BE DOING THIS NOW
+21 IF $$PARM^ACHS(2,16)'="Y"
Begin DoDot:1
+22 ;IF NOT DENTAL PRINT 43 & 64 FORMS
IF ACHSTYPV'=2
DO ^ACHSRP3
QUIT
+23 ;ELSE PRINT 57 DENTAL FORMS
DO ^ACHSRP3D
End DoDot:1
+24 ;
+25 ;
+26 ;??????????
IF $DATA(ACHSRPNT)
KILL ^TMP("ACHSRR",$JOB,DUZ(2),ACHSTYPV,ACHSDIEN,ACHSTIEN)
DO END
QUIT
+27 ;??????LETS THINK ABOUT WHY THIS IS LOCKED
LOCK +^ACHS(7,ACHS7DA):60
+28 ;
+29 ;NOW THAT WE KNOW WE PRINTED A DOCUMENT LETS CREATE THE RECORD
+30 SET X=$GET(^ACHS(7,ACHS7DA,"D",0))
+31 ;INCREMENT ENTRY
SET N=$PIECE(X,U,3)+1
+32 ;INCREMENT LAST ENTRY USED
SET M=$PIECE(X,U,4)+1
+33 SET ^ACHS(7,ACHS7DA,"D",N,0)=ACHSORDN_U_DUZ(2)_U_ACHSDIEN_U_ACHSTIEN
+34 SET ^ACHS(7,ACHS7DA,"D","B",ACHSORDN,N)=""
+35 SET ^ACHS(7,ACHS7DA,"D",0)=$PIECE(X,U,1,2)_U_N_U_M
+36 SET ^ACHS(7,"P",DUZ(2),ACHSDIEN,ACHSTIEN,ACHS7DA,N)=""
+37 LOCK -^ACHS(7,ACHS7DA):60
+38 KILL ^ACHSF("PQ",DUZ(2),ACHSTYPV,ACHSDIEN,ACHSTIEN)
+39 QUIT
END ;
+1 KILL A,B,C,D,E,F,I,R,N,ACHSIPRM
+2 ;ITSC/SET/JVK ACHS*3.1*11 kill vars below
+3 KILL ACHSMPP,ACHSDS,ACHSMPN
+4 QUIT
+5 ;
INIT ;EP - Initialize local vars to existing document data.
+1 ;THIS ENTRY CALLED BY ACHSAJ,ACHSBUG3,ACHSPAM,ACHSUSC
+2 ;SET NOTFOUND VARIABLE TO UNDEFINED STRINGS
+3 DO KILLNULS
+4 KILL ACHSNOTF
+5 SET $PIECE(ACHSNOTF," --- "_U,30)=""
+6 ;DOC NODE 0
SET ACHSDOC0=$GET(^ACHSF(DUZ(2),"D",ACHSDIEN,0),ACHSNOTF)
+7 ;DOC NODE 1
SET ACHSDOC1=$GET(^ACHSF(DUZ(2),"D",ACHSDIEN,1),ACHSNOTF)
+8 ;DOC NODE 2
SET ACHSDOC2=$GET(^ACHSF(DUZ(2),"D",ACHSDIEN,2),ACHSNOTF)
+9 ;DOC NODE 3
SET ACHSDOC3=$GET(^ACHSF(DUZ(2),"D",ACHSDIEN,3),ACHSNOTF)
+10 ;TRANS NODE 0
SET ACHSTRA0=$GET(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN,0),ACHSNOTF)
+11 ;
+12 ;contract pointer is not printed, so it does not get set via UNDEF
+13 ;CONTRACT PTR
SET ACHSCONP=$PIECE(ACHSDOC0,U,5)
+14 ;ITSC/SET/JVK ACHS*3.1*11 Set Medicare Prov. Pointer
+15 ;MEDICARE PROV. PTR.
SET ACHSMPP=$PIECE(ACHSDOC1,U,4)
+16 ;
+17 ;COMMON ACCT #
SET ACHSCAN=$$UNDEF($PIECE(ACHSDOC0,U,6))
+18 ;OBJECT CLASS.
SET ACHSSCC=$$UNDEF($PIECE(ACHSDOC0,U,7))
+19 ;VENDOR CHRG. EST.
SET ACHSOBJC=$$UNDEF($PIECE(ACHSDOC0,U,10))
+20 ;FISCAL YEAR
SET S=$$UNDEF($PIECE(ACHSDOC0,U,14))
+21 ;TYPE OF SERVICE
SET ACHSTYP=$$UNDEF($PIECE(ACHSDOC0,U,4))
+22 ;COMMENTS OPTIONAL
SET ACHSCOPT=$$UNDEF($PIECE(ACHSDOC0,U,13))
+23 ;ORDER DATE
SET ACHSODT=$$UNDEF($PIECE(ACHSDOC0,U,2))
+24 ;BLANKET ORDER?
SET ACHSBLAN=$$UNDEF($PIECE(ACHSDOC0,U,3))
+25 ;DOCUMENT DEST.
SET ACHSDEST=$$UNDEF($PIECE(ACHSDOC0,U,17))
+26 ;DOCUMENT CONTROL REGISTER
SET ACHSDCR=$$UNDEF($PIECE(ACHSDOC0,U,19))
+27 ;ITSC/SET/JVK ACHS*3.1*7 ADDED NEXT FOUR LINES
+28 ;E SIG
SET ACHSESIG=$$GET1^DIQ(200,$$UNDEF($PIECE(ACHSDOC0,U,24)),.01)
+29 ;E DATE
SET Y=$$UNDEF($PIECE(ACHSDOC0,U,28))
XECUTE ^DD("DD")
SET ACHSEDTE=Y
+30 ;AUTH SIG
SET ACHSASIG=$$GET1^DIQ(200,$$UNDEF($PIECE(ACHSDOC0,U,29)),.01)
+31 ;A DATE
SET Y=$$UNDEF($PIECE(ACHSDOC0,U,30))
XECUTE ^DD("DD")
SET ACHSADTE=Y
+32 ;
+33 ;PROVIDER INFO
+34 ;PROVIDER PTR
SET ACHSPROV=$$UNDEF($PIECE(ACHSDOC0,U,8))
+35 ;VENDOR AGREE. PTR
SET ACHSAGRP=$$UNDEF($PIECE(ACHSDOC0,U,23))
+36 SET ACHSPR18=""
+37 IF ACHSAGRP'=""
SET ACHSPR18=$GET(^AUTTVNDR(ACHSPROV,18,ACHSAGRP,0),ACHSNOTF)
+38 ;MEDICARE RATE OUTPATIENT
SET ACHSMRTO=$$UNDEF($PIECE(ACHSPR18,U,5))
+39 ;MEDICARE RATE INPATIENT
SET ACHSMRTI=$$UNDEF($PIECE(ACHSPR18,U,4))
+40 ;ITSC/SET/JVK ACHS*3.1*11 - nxt. three lines
+41 IF ACHSMPP'=""
SET ACHSMPN=$PIECE($GET(^AUTTVNDR(ACHSPROV,"MP",ACHSMPP,0)),U)
+42 IF ACHSMPP'=""
SET ACHSDS=$PIECE($GET(^AUTTVNDR(ACHSPROV,"MP",ACHSMPP,0)),U,2)
+43 IF ACHSMPP'=""
SET ACHSDS=$$EXTSET^XBFUNC(9999999.112303,2,ACHSDS)
+44 ;
+45 ;
+46 ;FULL ORDER #
SET ACHSORDN=S_"-"_ACHSFC_"-"_$PIECE(ACHSDOC0,U)
+47 ;
+48 ;FACILITY INFO
+49 ;PATIENT FACILITY PTR
SET ACHSPATF=$$UNDEF($PIECE(ACHSDOC0,U,20))
+50 ;LOCATION NODE 0
SET ACHSLOC0=$GET(^AUTTLOC(ACHSPATF,0),ACHSNOTF)
+51 ;
+52 ;TRANSACTION INFO
+53 ;DATE OF SERVICE
SET ACHSDOS=$PIECE(ACHSTRA0,U,10)
+54 ;TRANSACTION TYPE
SET ACHSTYPE=$PIECE(ACHSTRA0,U,2)
+55 ;CANCEL NUMBER
SET ACHSLCA=$PIECE(ACHSTRA0,U,7)
+56 ;
+57 ;GET SUPPLEMENT NUMBER
+58 SET ACHSSF=$SELECT($PIECE(ACHSTRA0,U,6)="":"",1:"S"_$PIECE(ACHSTRA0,U,6))
+59 ;
+60 ;IF NO SUPP NUM. MAYBE BE CANCEL NUMBER
+61 IF ACHSSF=""
SET ACHSSF=$SELECT($PIECE(ACHSTRA0,U,7)="":"",1:"C"_$PIECE(ACHSTRA0,U,7))
+62 ;
+63 SET E(7)=ACHSODT
+64 ;TRANSACTION TYPE SET IN INIT^ACHSRP2
IF ACHSTYPE="S"
Begin DoDot:1
+65 ;MOVE ORDER DATE TO E(11)
SET E(11)=E(7)
+66 ;TRANSACTION DATE
SET X=$PIECE(ACHSTRA0,U)
+67 IF X'=" --- "
SET E(7)=$EXTRACT(X,4,5)_"-"_$EXTRACT(X,6,7)_"-"_$EXTRACT(X,2,3)
+68 IF '$TEST
SET E(7)=X
End DoDot:1
+69 ;
+70 ;NEXT LINE GETS 'REFERRAL TYPE (DENTAL ONLY)' FROM DOCUMENT SUBFILE
+71 ;AND 'REFERRAL TYPE (NOT USED)' FROM TRANSACTION SUBFILE
+72 SET ACHSREFT=$EXTRACT($PIECE(ACHSTRA0,U,11)_$PIECE(ACHSDOC3,U,10))
+73 ;
+74 KILL ACHSBLKF
+75 ;
+76 ;IF THIS IS A BLANKET ORDER GET BLANKET ORDER TYPE
+77 IF ACHSBLAN
SET ACHSBLKF=""
SET ACHSBLT=$GET(^ACHSF(DUZ(2),"D",ACHSDIEN,"BT"))
+78 ;ITSC/SET/JVK ACHS*3.1*7 COMMENT OUT BELOW ADD ACHSSISIG,ACHSSIG
+79 ;S ACHSSIG=$P($G(^ACHSF(DUZ(2),"P")),U,ACHSTYP) ;?????????
+80 ;DOC INITIATOR
SET ACHSISIG=$$GET1^DIQ(200,$$UNDEF($PIECE(ACHSDOC0,U,18)),.01)
+81 ;TITLE
SET ACHSSIG=$$GET1^DIQ(200,$$UNDEF($PIECE(ACHSDOC0,U,18)),20.3)
+82 ;IHS PAYMENT AMOUNT
SET ACHSESDO=$$UNDEF($PIECE(ACHSTRA0,U,4))
+83 ;PATIENT PTR
SET DFN=$$UNDEF($PIECE(ACHSTRA0,U,3))
+84 ;
+85 SET (ACHSEDOS,ACHSFDT,ACHSTDT)=""
+86 IF ACHSTYP
Begin DoDot:1
+87 ;AUTH BEGINNING DATE
SET ACHSFDT=$$UNDEF($PIECE(ACHSDOC3,U))
+88 SET ACHSTDT=$PIECE(ACHSDOC3,U,2)
+89 ;1/10/02 pmf that's not how you add days to a date
+90 ;I ACHSTYP=1,(ACHSTDT="") S ACHSTDT=$P(ACHSDOC3,U,1)+$P(ACHSDOC1,U,1) ; ACHS*3.1*3
+91 ; ACHS*3.1*3
IF ACHSTYP=1
IF (ACHSTDT="")
NEW X,X1,X2
SET X1=ACHSFDT
SET X2=$PIECE(ACHSDOC1,U,1)
DO C^%DTC
SET ACHSTDT=X
+92 ;
+93 ;AUTH ENDING DATE
SET ACHSTDT=$$UNDEF(ACHSTDT)
+94 ;EST. DATE OF SERVICE
SET ACHSEDOS=$$UNDEF($PIECE(ACHSDOC3,U,9))
+95 ;
IF ACHSEDOS=""
SET ACHSEDOS=ACHSFDT
End DoDot:1
+96 ;ESTIMATED INPATIENT DAYS
SET ACHSESDA=$$UNDEF($PIECE(ACHSDOC1,U))
+97 ; ;HOSPITAL TYPE ONLY????
+98 ;HOSPITAL ORDER #
SET ACHSHON=$$UNDEF($PIECE(ACHSDOC2,U))
+99 ; ;DENTAL ONLY????
+100 ;DESCRIPTION OF SERVICE
SET ACHSDES=$$UNDEF($PIECE(ACHSDOC1,U,2))
+101 SET A(7)=ACHSDES
+102 ;GET PATIENT, FACILITY &
DO PRT^ACHSUDF
+103 ; ;INSURANCE INFO
+104 QUIT
+105 ;RESET ARRAY VALUES TO NULL
KILLNULS ;
+1 FOR ACHSX="A","B","C","D","E","F"
FOR ACHSY=1:1:12
SET ACHS=ACHSX_"("_ACHSY_")"
SET @(ACHS)=" --- "
+2 QUIT
+3 ;
REF ; Set Referral Physician and Medical Priority into print vars.
+1 ;DON'T GET INFO IF BLANKET ORDER
IF $DATA(ACHSBLKF)
QUIT
+2 SET (ACHSDX,ACHSPX,X,N)=""
+3 ;
+4 ;FIX REF TO LOOK AT 80 INSTEAD OF 50
SET ACHS200=$SELECT($GET(^DD(9002080.01,80,0))["VA(200,":1,1:0)
+5 ;
+6 ;FIX THE REFERRAL PHYSICIAN DISPLAY PROBLEM
IF $DATA(^ACHSF(DUZ(2),"D",ACHSDIEN,3))
Begin DoDot:1
+7 ;REFERRING PHYSICIAN PTR
SET R(1)=$$UNDEF($PIECE(ACHSDOC3,U,5))
+8 ;
+9 ;REFERRAL MEDICAL PRIORITY ;FIX THE REFERRAL PHYSICIAN DISPLAY PROBLEM
SET R(2)=$$UNDEF($PIECE(ACHSDOC3,U,6))
+10 ;
+11 ;FIX THE REFERRAL PHYSICIAN DISPLAY PROBLEM
IF ACHS200
IF R(1)>0
SET R(1)=$PIECE($GET(^VA(200,R(1),0)," --- "),U)
+12 ;IHS/SET/GTH ACHS*3.1*5 12/06/2002
+13 IF 'ACHS200
Begin DoDot:2
+14 SET ACHSREFP=$$UNDEF($PIECE($GET(^DIC(6,R(1),0)),U))
+15 ;FIX THE REFERRAL PHYSICIAN DISPLAY PROBLEM
IF +R(1)>0
SET R(1)=$$UNDEF($PIECE($GET(^DIC(16,ACHSREFP,0)),U))
End DoDot:2
+16 ;FIX THE REFERRAL PHYSICIAN DISPLAY PROBLEM
IF R(2)
IF R(2)["I"
SET R(2)=$$UNDEF($PIECE($TEXT(@R(2)),";;",2))
End DoDot:1
+17 ;
+18 ;
PROC ; Set Referral Procedure Narrative into print vars for regular Form.
+1 ;IF PRINTING UNIVERSAL FORM
IF $$PARM^ACHS(2,16)="Y"
GOTO PROC1
+2 IF '$DATA(^ACHSF(DUZ(2),"D",ACHSDIEN,7))
GOTO DIAG
+3 ;DOCUMENT 7 NODE
SET ACHSPX=$GET(^ACHSF(DUZ(2),"D",ACHSDIEN,7))
+4 ; ;REFERRAL PX NARRATIVE
+5 IF $LENGTH(ACHSPX)>190
SET R("P",1)=$EXTRACT(ACHSPX,1,22)
SET N=23
+6 IF $LENGTH(ACHSPX)<190
SET R("P",1)=""
SET N=1
+7 FOR X=2:1:5
SET R("P",X)=$EXTRACT(ACHSPX,N,N+37)
SET N=N+38
DIAG ; Set Referral Diagnosis Narrative into print vars for regular Form.
+1 IF '$DATA(^ACHSF(DUZ(2),"D",ACHSDIEN,5))
GOTO EXT
+2 SET ACHSDX=$GET(^ACHSF(DUZ(2),"D",ACHSDIEN,5))
+3 IF $LENGTH(ACHSDX)>148
SET R("D",1)=$EXTRACT(ACHSDX,1,22)
SET N=23
+4 IF $LENGTH(ACHSDX)<148
SET R("D",1)=""
SET N=1
+5 FOR X=2:1:4
SET R("D",X)=$EXTRACT(ACHSDX,N,N+36)
SET N=N+37
EXT ;
+1 KILL ACHSDX,ACHSPX,X,N
+2 QUIT
+3 ;
REFCOD ;
I ;;Emergent/Acutely Urg
II ;;Preventive Sevices
III ;;Prim/Sec Services
IV ;;Chr Tert/Exten Svc
+1 ;
+2 ;
PROC1 ; Set Referral Procedure Narrative into print vars for Universal Form.
+1 IF '$DATA(^ACHSF(DUZ(2),"D",ACHSDIEN,7))
GOTO DIAG1
SET ACHSPX=$GET(^ACHSF(DUZ(2),"D",ACHSDIEN,7))
+2 IF $LENGTH(ACHSPX)>118
SET R("P",1)=$EXTRACT(ACHSPX,1,22)
SET N=23
+3 IF $LENGTH(ACHSPX)<118
SET R("P",1)=""
SET N=1
+4 FOR X=2:1:4
SET R("P",X)=$EXTRACT(ACHSPX,N,N+36)
SET N=N+37
DIAG1 ; Set Referral Diagnosis Narrative into print vars for Universal Form.
+1 IF '$DATA(^ACHSF(DUZ(2),"D",ACHSDIEN,5))
GOTO EXT1
SET ACHSDX=$GET(^ACHSF(DUZ(2),"D",ACHSDIEN,5))
+2 IF $LENGTH(ACHSDX)>72
SET R("D",1)=$EXTRACT(ACHSDX,1,22)
SET N=23
+3 IF $LENGTH(ACHSDX)<72
SET R("D",1)=""
SET N=1
+4 FOR X=2:1:3
SET R("D",X)=$EXTRACT(ACHSDX,N,N+36)
SET N=N+37
EXT1 ;
+1 KILL ACHSDX,ACHSPX,X,N
+2 QUIT
+3 ;
+4 ;RETURN " --- " IF NULL
UNDEF(X) ;
+1 IF X="UNDEFINED"!(X="")
QUIT " --- "
+2 QUIT X
+3 ;
