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

ACHSRP2.m

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