ACHSRPF1 ; IHS/OIT/FCJ - PRINT CHS FORM AND DATA 2 OF 3 - INIT VARS; [ 01/21/2005 3:50 PM ] ; 30 Jun 2011 10:09 AM
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**18,19,20**;JUNE 11,2001
;3.1*18 NEW ROUTINE
;CALLED FROM ACHSRPF
;
ST ;
;IF NO DATA FOR DOCUMENT OR TRANSACTION QUIT
I '$D(^ACHSF(DUZ(2),"D",ACHSDIEN,0))!'$D(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN,0)) D END Q
;QUIT IF PAR SET TO NO ON CANCEL OR SUPPLEMENT
S ACHSTYPE=$P(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN,0),U,2) ;ACHS*3.1*19
I $$PARM^ACHS(2,6)="N",(ACHSTYPE=4)!(ACHSTYPE=2) Q ;ACHS*3.1*19
I $$PARM^ACHS(2,7)="N",ACHSTYPE=1 Q ;ACHS*3.1*19
;
D INIT,REF:ACHSTYP'=2
D ^ACHSRPFU
;
DOCP ;
I $D(ACHSRPNT) K ^TMP("ACHSRR",$J,DUZ(2),ACHSTYPV,ACHSDIEN,ACHSTIEN) D END Q
;
;ADD DOCUMENT TO CHS DOCUMENTED PRINTED LIST FILE
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)
;
END ;
; Removed following line so we keep ^TMP("ACHSPO",$J around for printing
;K ^TMP("ACHSPO",$J,ACHSDIEN,ACHSTIEN)
K A,B,C,D,E,F,I,R,N
Q
;
INIT ; Initialize local vars for existing document data.
;SET NOTFOUND VARIABLE TO UNDEFINED STRINGS
D KILLNULS
K ACHSNOTF
S $P(ACHSNOTF," --- "_U,30)=""
S ACHSARCO=$P(^ACHSF(DUZ(2),0),U,11)
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
;
S ACHSCONP=$P(ACHSDOC0,U,5) ;CONTRACT 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="" S:$$PARM^ACHS(2,18)="Y" ACHSDCR="DCR: "_$P(ACHSDOC0,U,19) ;DOCUMENT CONTROL REGISTER ACHS*3.1*19
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 ACHSMPP=$P(ACHSDOC1,U,4) ;MEDICARE PROV. PTR.
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
I ACHSMPP'="" S ACHSMPN=$P($G(^AUTTVNDR(ACHSPROV,"MP",ACHSMPP,0)),U),ACHSDS=$P($G(^(0)),U,2),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 CANCEL OR SUPPLEMENT NUMBER
S ACHSSF=$S(ACHSTYPE="C":"C"_$P(ACHSTRA0,U,7),ACHSTYPE="S":"S"_$P(ACHSTRA0,U,6),1:"")
;
S E(7)=ACHSODT
I ACHSTYPE="S" D
.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"))
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)
. I ACHSTYP=1,(ACHSTDT="") N X,X1,X2 S X1=ACHSFDT,X2=$P(ACHSDOC1,U,1) D C^%DTC S ACHSTDT=X
. ;
.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
;
S ACHSHON=$$UNDEF($P(ACHSDOC2,U)) ;HOSPITAL ORDER #
;
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)
;
I $D(^ACHSF(DUZ(2),"D",ACHSDIEN,3)) D
.S R(1)=$$UNDEF($P(ACHSDOC3,U,5)) ;REFERRING PHYSICIAN PTR
.;
.S R(2)=$$UNDEF($P(ACHSDOC3,U,6)) ;REFERRAL MEDICAL PRIORITY
.;
.I ACHS200 S:R(1)>0 R(1)=$P($G(^VA(200,R(1),0)," --- "),U)
.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))
. I R(2),R(2)["I" S R(2)=$$UNDEF($P($T(@R(2)),";;",2))
;
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
;
UNDEF(X) ;
;RETURN " --- " IF NULL
I X="UNDEFINED"!(X="") Q " --- "
Q X
;
REFCOD ;
I ;;Emergent/Acutely Urg
II ;;Preventive Services
III ;;Prim/Sec Services
IV ;;Chr Tert/Exten Svc
;
ACHSRPF1 ; IHS/OIT/FCJ - PRINT CHS FORM AND DATA 2 OF 3 - INIT VARS; [ 01/21/2005 3:50 PM ] ; 30 Jun 2011 10:09 AM
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**18,19,20**;JUNE 11,2001
+2 ;3.1*18 NEW ROUTINE
+3 ;CALLED FROM ACHSRPF
+4 ;
ST ;
+1 ;IF NO DATA FOR DOCUMENT OR TRANSACTION QUIT
+2 IF '$DATA(^ACHSF(DUZ(2),"D",ACHSDIEN,0))!'$DATA(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN,0))
DO END
QUIT
+3 ;QUIT IF PAR SET TO NO ON CANCEL OR SUPPLEMENT
+4 ;ACHS*3.1*19
SET ACHSTYPE=$PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN,0),U,2)
+5 ;ACHS*3.1*19
IF $$PARM^ACHS(2,6)="N"
IF (ACHSTYPE=4)!(ACHSTYPE=2)
QUIT
+6 ;ACHS*3.1*19
IF $$PARM^ACHS(2,7)="N"
IF ACHSTYPE=1
QUIT
+7 ;
+8 DO INIT
IF ACHSTYP'=2
DO REF
+9 DO ^ACHSRPFU
+10 ;
DOCP ;
+1 IF $DATA(ACHSRPNT)
KILL ^TMP("ACHSRR",$JOB,DUZ(2),ACHSTYPV,ACHSDIEN,ACHSTIEN)
DO END
QUIT
+2 ;
+3 ;ADD DOCUMENT TO CHS DOCUMENTED PRINTED LIST FILE
+4 SET X=$GET(^ACHS(7,ACHS7DA,"D",0))
+5 ;INCREMENT ENTRY
SET N=$PIECE(X,U,3)+1
+6 ;INCREMENT LAST ENTRY USED
SET M=$PIECE(X,U,4)+1
+7 SET ^ACHS(7,ACHS7DA,"D",N,0)=ACHSORDN_U_DUZ(2)_U_ACHSDIEN_U_ACHSTIEN
+8 SET ^ACHS(7,ACHS7DA,"D","B",ACHSORDN,N)=""
+9 SET ^ACHS(7,ACHS7DA,"D",0)=$PIECE(X,U,1,2)_U_N_U_M
+10 SET ^ACHS(7,"P",DUZ(2),ACHSDIEN,ACHSTIEN,ACHS7DA,N)=""
+11 LOCK -^ACHS(7,ACHS7DA):60
+12 KILL ^ACHSF("PQ",DUZ(2),ACHSTYPV,ACHSDIEN,ACHSTIEN)
+13 ;
END ;
+1 ; Removed following line so we keep ^TMP("ACHSPO",$J around for printing
+2 ;K ^TMP("ACHSPO",$J,ACHSDIEN,ACHSTIEN)
+3 KILL A,B,C,D,E,F,I,R,N
+4 QUIT
+5 ;
INIT ; Initialize local vars for existing document data.
+1 ;SET NOTFOUND VARIABLE TO UNDEFINED STRINGS
+2 DO KILLNULS
+3 KILL ACHSNOTF
+4 SET $PIECE(ACHSNOTF," --- "_U,30)=""
+5 SET ACHSARCO=$PIECE(^ACHSF(DUZ(2),0),U,11)
+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 PTR
SET ACHSCONP=$PIECE(ACHSDOC0,U,5)
+13 ;COMMON ACCT #
SET ACHSCAN=$$UNDEF($PIECE(ACHSDOC0,U,6))
+14 ;OBJECT CLASS.
SET ACHSSCC=$$UNDEF($PIECE(ACHSDOC0,U,7))
+15 ;VENDOR CHRG. EST.
SET ACHSOBJC=$$UNDEF($PIECE(ACHSDOC0,U,10))
+16 ;FISCAL YEAR
SET S=$$UNDEF($PIECE(ACHSDOC0,U,14))
+17 ;TYPE OF SERVICE
SET ACHSTYP=$$UNDEF($PIECE(ACHSDOC0,U,4))
+18 ;COMMENTS OPTIONAL
SET ACHSCOPT=$$UNDEF($PIECE(ACHSDOC0,U,13))
+19 ;ORDER DATE
SET ACHSODT=$$UNDEF($PIECE(ACHSDOC0,U,2))
+20 ;BLANKET ORDER?
SET ACHSBLAN=$$UNDEF($PIECE(ACHSDOC0,U,3))
+21 ;DOCUMENT DEST.
SET ACHSDEST=$$UNDEF($PIECE(ACHSDOC0,U,17))
+22 ;DOCUMENT CONTROL REGISTER ACHS*3.1*19
SET ACHSDCR=""
IF $$PARM^ACHS(2,18)="Y"
SET ACHSDCR="DCR: "_$PIECE(ACHSDOC0,U,19)
+23 ;E SIG
SET ACHSESIG=$$GET1^DIQ(200,$$UNDEF($PIECE(ACHSDOC0,U,24)),.01)
+24 ;E DATE
SET Y=$$UNDEF($PIECE(ACHSDOC0,U,28))
XECUTE ^DD("DD")
SET ACHSEDTE=Y
+25 ;AUTH SIG
SET ACHSASIG=$$GET1^DIQ(200,$$UNDEF($PIECE(ACHSDOC0,U,29)),.01)
+26 ;A DATE
SET Y=$$UNDEF($PIECE(ACHSDOC0,U,30))
XECUTE ^DD("DD")
SET ACHSADTE=Y
+27 ;
+28 ;PROVIDER INFO
+29 ;MEDICARE PROV. PTR.
SET ACHSMPP=$PIECE(ACHSDOC1,U,4)
+30 ;PROVIDER PTR
SET ACHSPROV=$$UNDEF($PIECE(ACHSDOC0,U,8))
+31 ;VENDOR AGREE. PTR
SET ACHSAGRP=$$UNDEF($PIECE(ACHSDOC0,U,23))
+32 SET ACHSPR18=""
+33 IF ACHSAGRP'=""
SET ACHSPR18=$GET(^AUTTVNDR(ACHSPROV,18,ACHSAGRP,0),ACHSNOTF)
+34 ;MEDICARE RATE OUTPATIENT
SET ACHSMRTO=$$UNDEF($PIECE(ACHSPR18,U,5))
+35 ;MEDICARE RATE INPATIENT
SET ACHSMRTI=$$UNDEF($PIECE(ACHSPR18,U,4))
+36 IF ACHSMPP'=""
SET ACHSMPN=$PIECE($GET(^AUTTVNDR(ACHSPROV,"MP",ACHSMPP,0)),U)
SET ACHSDS=$PIECE($GET(^(0)),U,2)
SET ACHSDS=$$EXTSET^XBFUNC(9999999.112303,2,ACHSDS)
+37 ;
+38 ;FULL ORDER #
SET ACHSORDN=S_"-"_ACHSFC_"-"_$PIECE(ACHSDOC0,U)
+39 ;
+40 ;FACILITY INFO
+41 ;PATIENT FACILITY PTR
SET ACHSPATF=$$UNDEF($PIECE(ACHSDOC0,U,20))
+42 ;LOCATION NODE 0
SET ACHSLOC0=$GET(^AUTTLOC(ACHSPATF,0),ACHSNOTF)
+43 ;
+44 ;TRANSACTION INFO
+45 ;DATE OF SERVICE
SET ACHSDOS=$PIECE(ACHSTRA0,U,10)
+46 ;TRANSACTION TYPE
SET ACHSTYPE=$PIECE(ACHSTRA0,U,2)
+47 ;CANCEL NUMBER
SET ACHSLCA=$PIECE(ACHSTRA0,U,7)
+48 ;
+49 ;GET CANCEL OR SUPPLEMENT NUMBER
+50 SET ACHSSF=$SELECT(ACHSTYPE="C":"C"_$PIECE(ACHSTRA0,U,7),ACHSTYPE="S":"S"_$PIECE(ACHSTRA0,U,6),1:"")
+51 ;
+52 SET E(7)=ACHSODT
+53 IF ACHSTYPE="S"
Begin DoDot:1
+54 ;MOVE ORDER DATE TO E(11)
SET E(11)=E(7)
+55 ;TRANSACTION DATE
SET X=$PIECE(ACHSTRA0,U)
+56 IF X'=" --- "
SET E(7)=$EXTRACT(X,4,5)_"-"_$EXTRACT(X,6,7)_"-"_$EXTRACT(X,2,3)
+57 IF '$TEST
SET E(7)=X
End DoDot:1
+58 ;
+59 ;NEXT LINE GETS 'REFERRAL TYPE (DENTAL ONLY)' FROM DOCUMENT SUBFILE
+60 ;AND 'REFERRAL TYPE (NOT USED)' FROM TRANSACTION SUBFILE
+61 SET ACHSREFT=$EXTRACT($PIECE(ACHSTRA0,U,11)_$PIECE(ACHSDOC3,U,10))
+62 ;
+63 KILL ACHSBLKF
+64 ;
+65 ;IF THIS IS A BLANKET ORDER GET BLANKET ORDER TYPE
+66 IF ACHSBLAN
SET ACHSBLKF=""
SET ACHSBLT=$GET(^ACHSF(DUZ(2),"D",ACHSDIEN,"BT"))
+67 ;DOC INITIATOR
SET ACHSISIG=$$GET1^DIQ(200,$$UNDEF($PIECE(ACHSDOC0,U,18)),.01)
+68 ;TITLE
SET ACHSSIG=$$GET1^DIQ(200,$$UNDEF($PIECE(ACHSDOC0,U,18)),20.3)
+69 ;IHS PAYMENT AMOUNT
SET ACHSESDO=$$UNDEF($PIECE(ACHSTRA0,U,4))
+70 ;PATIENT PTR
SET DFN=$$UNDEF($PIECE(ACHSTRA0,U,3))
+71 ;
+72 SET (ACHSEDOS,ACHSFDT,ACHSTDT)=""
+73 IF ACHSTYP
Begin DoDot:1
+74 ;AUTH BEGINNING DATE
SET ACHSFDT=$$UNDEF($PIECE(ACHSDOC3,U))
+75 SET ACHSTDT=$PIECE(ACHSDOC3,U,2)
+76 IF ACHSTYP=1
IF (ACHSTDT="")
NEW X,X1,X2
SET X1=ACHSFDT
SET X2=$PIECE(ACHSDOC1,U,1)
DO C^%DTC
SET ACHSTDT=X
+77 ;
+78 ;AUTH ENDING DATE
SET ACHSTDT=$$UNDEF(ACHSTDT)
+79 ;EST. DATE OF SERVICE
SET ACHSEDOS=$$UNDEF($PIECE(ACHSDOC3,U,9))
+80 ;
IF ACHSEDOS=""
SET ACHSEDOS=ACHSFDT
End DoDot:1
+81 ;ESTIMATED INPATIENT DAYS
SET ACHSESDA=$$UNDEF($PIECE(ACHSDOC1,U))
+82 ;
+83 ;HOSPITAL ORDER #
SET ACHSHON=$$UNDEF($PIECE(ACHSDOC2,U))
+84 ;
+85 ;DESCRIPTION OF SERVICE
SET ACHSDES=$$UNDEF($PIECE(ACHSDOC1,U,2))
+86 SET A(7)=ACHSDES
+87 ;GET PATIENT, FACILITY &
DO PRT^ACHSUDF
+88 ; ;INSURANCE INFO
+89 QUIT
+90 ;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 SET ACHS200=$SELECT($GET(^DD(9002080.01,80,0))["VA(200,":1,1:0)
+5 ;
+6 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
SET R(2)=$$UNDEF($PIECE(ACHSDOC3,U,6))
+10 ;
+11 IF ACHS200
IF R(1)>0
SET R(1)=$PIECE($GET(^VA(200,R(1),0)," --- "),U)
+12 IF 'ACHS200
Begin DoDot:2
+13 SET ACHSREFP=$$UNDEF($PIECE($GET(^DIC(6,R(1),0)),U))
+14 IF +R(1)>0
SET R(1)=$$UNDEF($PIECE($GET(^DIC(16,ACHSREFP,0)),U))
End DoDot:2
+15 IF R(2)
IF R(2)["I"
SET R(2)=$$UNDEF($PIECE($TEXT(@R(2)),";;",2))
End DoDot:1
+16 ;
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 ;
UNDEF(X) ;
+1 ;RETURN " --- " IF NULL
+2 IF X="UNDEFINED"!(X="")
QUIT " --- "
+3 QUIT X
+4 ;
REFCOD ;
I ;;Emergent/Acutely Urg
II ;;Preventive Services
III ;;Prim/Sec Services
IV ;;Chr Tert/Exten Svc
+1 ;
