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

DGPTUTL.m

Go to the documentation of this file. 
  1. DGPTUTL ;ALB/AS - PTF UTILITY ROUTINE ; 8/14/03 11:35am
  1.  ;;5.3;Registration;**26,114,234,466,544,1015**;Aug 13, 1993;Build 21
  1. D I $L(Y)'<7 S %=$E(Y,4,5)*3,Y=$E("JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC",%-2,%)_" "_$S($E(Y,6,7):$J(+$E(Y,6,7),2)_",",1:"")_($E(Y,1,3)+1700)_$S(Y[".":" "_$E(Y_0,9,10)_":"_$E(Y_"000",11,12),1:"") Q
  1.  S Y="" Q
  1. PM ;sets variables from ^DGPM global
  1.  S DGPMCA=$O(^DGPM("APTF",PTF,0)),DGPMAN=$S($D(^DGPM(+DGPMCA,0)):^(0),1:"") Q
  1. MT ;Determine and store Means Test Indicator
  1.  ;S DGZEC=$S($D(^DPT(DFN,.36)):$P(^(.36),U,1),1:""),DGZEC=$S($D(^DIC(8,+DGZEC,0)):^(0),1:"") I $P(DGZEC,U,5)="N" S DGX="N" G DIE
  1.  ;-- get eligibility code
  1.  S DGZEC=$P($G(^DGPT(PTF,101)),U,8),DGZEC=$S($D(^DIC(8,+DGZEC,0)):^(0),1:"") I $P(DGZEC,U,5)="N" S DGX="N" G DIE
  1.  ;-- admit prior to 7/1/86 is an X
  1.  I DGADM<2860701 S DGX="X" G DIE
  1.  ;--
  1.  I $D(^DGPT(PTF,101)),$D(^DIC(45.1,+^(101),0)),$P(^(0),"^",4) S DGX="X" G DIE
  1.  I $P(^DG(43,1,0),U,21),DGADM]"",$D(^DIC(42,+$P(DGPMAN,U,6),0)),$P(^(0),U,3)="D" S DGX="X" G DIE
  1.  S DGT=$P($G(^DGPT(PTF,70)),"."),DGZ1=$$LST^DGMTU(DFN,DGT) G AS:'DGZ1
  1.  ;-- sc < 50 %, %O non comp, movements are sc
  1.  I $P(DGZEC,U,4)=3,$$SC^DGMTR(DFN),$$ANYSC^DGPTSCAN(PTF) S DGX="AS" G DIE
  1.  ;-- sc <50 %, %0 non-comp, no movement sc, mt =a
  1.  I $P(DGZEC,U,4)=3,$$SC^DGMTR(DFN),'$$ANYSC^DGPTSCAN(PTF),$P(DGZ1,U,4)="A" S DGX="AN" G DIE
  1.  ;-- sc, >0%  - DG*5.3*544
  1.  I "^1^3^"[("^"_$P(DGZEC,U,4)_"^"),$P($G(^DPT(DFN,.3)),U,2)>0,$P(DGZ1,U,4)="A" S DGX="AS" G DIE
  1.  ;
  1.  S DGX=$S('$D(DGZ1):"U",1:$P(DGZ1,U,4))
  1.  ; Determine if the Pending Adjudication is for MT(C) GMT(G)
  1.  I DGX="P" D  G DIE
  1.  . I '+$P($G(DGZ1),U) S DGX="U" Q
  1.  . S DGX=$$PA^DGMTUTL($P(DGZ1,U)),DGX=$S('$D(DGX):"U",DGX="MT":"C",DGX="GMT":"G",1:"U")
  1.  S DGX=$S(DGX="A":"AN","BCGN"[DGX:DGX,1:"U") G DIE:DGX'="N"
  1.  ;-- AO or IR
  1. AS S DGZ=$S($D(^DPT(DFN,.321)):^(.321),1:0) I $P(DGZ,U,2)="Y"!($P(DGZ,U,3)="Y") S DGX="AS" G DIE
  1.  ;-- EC
  1.  S DGZ=$S($D(^DPT(DFN,.322)):^(.322),1:0) I $P(DGZ,U,13)="Y" S DGX="AS" G DIE
  1.  ;-- NTR
  1.  N DGNTARR S DGZ=$S($$GETCUR^DGNTAPI(DFN,"DGNTARR")>0:DGNTARR("NTR"),1:"") I $P(DGZ,U)="Y" S DGX="AS" G DIE
  1.  ;-- MST
  1.  S DGZ=$$GETSTAT^DGMSTAPI(DFN) I $P(DGZ,U,2)="Y" S DGX="AS" G DIE
  1.  ;-- if veteran and AA or Housebound
  1.  I $P(DGZEC,U,5)="Y",$P(DGZEC,U,4)<4,"^2^15^"'[(U_$P(DGZEC,U,9)_U) S DGX="AS" G DIE
  1.  ;
  1.  I DGZEC]"" S DGX="AN" G DIE
  1.  ;
  1.  S DGX="U" I '$D(DGLN) W !,"===> this patient has a blank Eligibility Code"
  1. DIE I '$D(DGBGJ) S DA=PTF,DR="10///"_DGX_$S('$P(^DGPT(PTF,0),U,3):";3///`"_$P($$SITE^VASITE,U),1:""),DIE="^DGPT(" D ^DIE K DGZEC,DGZ,DGZ1,DG1,DGX,DR,DGT,DA,DIE Q
  1.  I DGX'=$P(^DGPT(PTF,0),"^",10) S DA=PTF,DR="10///"_DGX,DIE="^DGPT(" D ^DIE
  1.  K DGZEC,DGZ,DGZ1,DG1,DGX,DGT,DR,DA,DIE Q
  1.  ;
  1. RTY ; -- set rec type variables
  1.  ;  input:      Y := rec type #
  1.  ; output:  DGRTY := rec type #
  1.  ;         DGRTY0 := name of type (in future, may expand to 0th node)
  1.  ;
  1.  I Y=1 S DGRTY=1,DGRTY0="PTF"
  1.  I Y=2 S DGRTY=2,DGRTY0="CENSUS"
  1.  Q
  1.  ;
  1. HANG ;
  1.  R DGPTHANG:4 K DGPTHANG Q
  1.  ;
  1. CEN ; -- find current active census ; return ifn and 0th node
  1.  S DGCN=$O(^DG(45.86,"AC",1,0)),DGCN0=$S($D(^DG(45.86,+DGCN,0)):^(0),1:"")
  1.  Q
  1.  ;
  1. FMT ; -- determime PTF record format
  1.  ;
  1.  S Z=$S(Y:Y,1:DT)
  1.  S DGPTFMT=1 D FDT
  1.  I Z>Y S DGPTFMT=2
  1.  K Z
  1.  Q
  1.  ;
  1. FDT ; -- set new format date for testing
  1.  S Y=2901000 Q
  1.  ;
  1. UPDT ; -- update PTF record w/PTF and DFN defined
  1.  I '$D(^DGPT(PTF,0)) W:'$D(ZTQUEUED) !!,*7,">>> PTF record #",PTF," does not exist." G UPDTQ
  1.  S X=^(0)
  1.  I $P(X,U,11)>1 W:'$D(ZTQUEUED) !!,*7,">>> Record #",PTF," is not a PTF record." G UPDTQ
  1.  S DGPTFE=$P(X,U,4),(DGADM,AD)=+$P(X,U,2),DGST=$D(^DGP(45.84,PTF))>0
  1.  I DGST W:'$D(ZTQUEUED) !!,*7,">>> PTF record #",PTF," is closed out. No updating allowed." G UPDTQ
  1.  I DGPTFE W:'$D(ZTQUEUED) !!,*7,">>> PTF record #",PTF," is a fee PTF record. No updating is possible." G UPDTQ
  1.  N DGPMCA,DGPMAN D PM
  1.  I DGPMCA D:'$P(^DGPT(PTF,0),U,5) SUF^DGPTF D LE^DGPTTS,DC^DGPTF
  1.  ;
  1. UPDTQ K AGE,D0,D1,DA,DGADM,DGLAST,DGP,DGTY,DIC,DIE,DR,DIV,DIU,DISYS,DIK,DIKLM,DIG,DIH,DI,DIW,DIWL,DIWR,DIWT,DN,DOB,DQ,DG,DRG,SEX,TY,L,P1,DIS2,DGPTFE,DGST,DGX,DFN1,DFN2,PR,I1,TDD,AD
  1.  Q
  1.  ;
  1. EXPL ; -- explode string A(input) to DGA(output)
  1.  N J,L S DGA=$E(A,2,999)
  1.  I DGA["-" S X=DGA,DGA="" F J=1:1 S L=$P(X,",",J) Q:'L  D EXPL1:L["-" S:L]"" DGA=DGA_L_"," Q:$P(X,",",J+1,999)=""
  1.  Q
  1.  ;
  1. EXPL1 ; -- explode string 'L' of form "1-12" ; input and output is 'L'
  1.  N I,X
  1.  I $P(L,"-")'?1N.N!($P(L,"-",2,999)'?1N.N) S L="" G EXPL1Q
  1.  I +L>$P(L,"-",2) S L="" G EXPL1Q
  1.  I +L=+$P(L,"-",2) S L=+L G EXPL1Q
  1.  S X="" F I=+L:1:+$P(L,"-",2) Q:($L(X)+$L(I)+1)>240  S X=X_I_","
  1.  S L=$E(X,1,$L(X)-1)
  1. EXPL1Q Q
  1.  ;
  1. CKPOS(ADEL,DEFAULT) ;-- This function will check the admitting eligibility
  1.  ; and the POS to make sure for Non-Vet eligibilities that a
  1.  ; 9 - Other or None POS is present.
  1.  ;
  1.  ;  INPUT - ADEL : Admitting Eligibility (Pointer to file 8)
  1.  ;       DEFAULT : Default POS (optional) (Pointer to file 21)
  1.  ;  OUTPUT- POS : POS Code. 0 - Error
  1.  ;
  1.  N RESULT,X,Y
  1.  ;If DFN is not needed here, kill DFN to avoid VADPT error out.
  1.  I $G(DFN)="" N DFN S DFN=$G(DGSDFN) I $G(DFN)="" K DFN
  1.  D ELIG^VADPT
  1.  I $D(VAEL(1))=1 S RESULT=$G(DEFAULT) G CKPOSQ
  1.  S RESULT=0,Y=$G(DEFAULT)
  1.  I '$D(^DIC(8,+ADEL,0)) G CKPOSQ
  1.  S X=$G(^DIC(8.1,$P($G(^DIC(8,+ADEL,0)),U,9),0))
  1.  ;-- if non vet set POS to Other
  1.  I $P(X,U,5)="N" S RESULT=9
  1.  ;-- if vet then use default
  1.  I $P(X,U,5)="Y",Y'="" S RESULT=Y
  1. CKPOSQ ;
  1.  Q RESULT
  1.  ;