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

ACHSRPF1.m

Go to the documentation of this file. 
  1. 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
  1.  ;3.1*18 NEW ROUTINE
  1.  ;CALLED FROM ACHSRPF
  1.  ;
  1. ST ;
  1.  ;IF NO DATA FOR DOCUMENT OR TRANSACTION QUIT
  1.  I '$D(^ACHSF(DUZ(2),"D",ACHSDIEN,0))!'$D(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN,0)) D END Q
  1.  ;QUIT IF PAR SET TO NO ON CANCEL OR SUPPLEMENT
  1.  S ACHSTYPE=$P(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN,0),U,2) ;ACHS*3.1*19
  1.  I $$PARM^ACHS(2,6)="N",(ACHSTYPE=4)!(ACHSTYPE=2) Q    ;ACHS*3.1*19
  1.  I $$PARM^ACHS(2,7)="N",ACHSTYPE=1 Q     ;ACHS*3.1*19
  1.  ;
  1.  D INIT,REF:ACHSTYP'=2
  1.  D ^ACHSRPFU
  1.  ;
  1. DOCP ;
  1.  I $D(ACHSRPNT) K ^TMP("ACHSRR",$J,DUZ(2),ACHSTYPV,ACHSDIEN,ACHSTIEN) D END Q
  1.  ;             
  1.  ;ADD DOCUMENT TO CHS DOCUMENTED PRINTED LIST FILE
  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.  ;
  1. END ;
  1.  ; Removed following line so we keep ^TMP("ACHSPO",$J around for printing
  1.  ;K ^TMP("ACHSPO",$J,ACHSDIEN,ACHSTIEN)
  1.  K A,B,C,D,E,F,I,R,N
  1.  Q
  1.  ;
  1. INIT ; Initialize local vars for existing document data.
  1.  ;SET NOTFOUND VARIABLE TO UNDEFINED STRINGS
  1.  D KILLNULS
  1.  K ACHSNOTF
  1.  S $P(ACHSNOTF," --- "_U,30)=""
  1.  S ACHSARCO=$P(^ACHSF(DUZ(2),0),U,11)
  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.  S ACHSCONP=$P(ACHSDOC0,U,5)                  ;CONTRACT PTR
  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="" S:$$PARM^ACHS(2,18)="Y" ACHSDCR="DCR: "_$P(ACHSDOC0,U,19)  ;DOCUMENT CONTROL REGISTER ACHS*3.1*19
  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 ACHSMPP=$P(ACHSDOC1,U,4)                   ;MEDICARE PROV. PTR.
  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.  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)
  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 CANCEL OR SUPPLEMENT NUMBER
  1.  S ACHSSF=$S(ACHSTYPE="C":"C"_$P(ACHSTRA0,U,7),ACHSTYPE="S":"S"_$P(ACHSTRA0,U,6),1:"")
  1.  ;
  1.  S E(7)=ACHSODT
  1.  I ACHSTYPE="S" D
  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.  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.  . I ACHSTYP=1,(ACHSTDT="") N X,X1,X2 S X1=ACHSFDT,X2=$P(ACHSDOC1,U,1) D C^%DTC S ACHSTDT=X
  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.  ;
  1.  S ACHSHON=$$UNDEF($P(ACHSDOC2,U))             ;HOSPITAL ORDER #
  1.  ;
  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)
  1.  ;
  1.  I $D(^ACHSF(DUZ(2),"D",ACHSDIEN,3)) D
  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
  1.  .;
  1.  .I ACHS200 S:R(1)>0 R(1)=$P($G(^VA(200,R(1),0)," --- "),U)
  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))
  1.  . I R(2),R(2)["I" S R(2)=$$UNDEF($P($T(@R(2)),";;",2))
  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. UNDEF(X) ;
  1.  ;RETURN " --- " IF NULL
  1.  I X="UNDEFINED"!(X="") Q " --- "
  1.  Q X
  1.  ; 
  1. REFCOD ;
  1. I ;;Emergent/Acutely Urg
  1. II ;;Preventive Services
  1. III ;;Prim/Sec Services
  1. IV ;;Chr Tert/Exten Svc
  1.  ;