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