- IB20PT86 ;ALB/CPM - EXPORT ROUTINE 'DGPTUTL' ; 14-FEB-94
- ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
- ;
- DGPTUTL ;ALB/AS - PTF UTILITY ROUTINE ; 12/13/89@8
- ;;5.3;Registration;**26**;Aug 13, 1993
- 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
- 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
- S DGX=$S('$D(DGZ1):"U",1:$P(DGZ1,U,4)),DGX=$S(DGX="A":"AN","BN"[DGX:DGX,"CP"[DGX:"C",1:"U") G DIE:DGX'="N"
- 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
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB20PT86 3606 printed Mar 13, 2025@21:10:22 Page 2
- IB20PT86 ;ALB/CPM - EXPORT ROUTINE 'DGPTUTL' ; 14-FEB-94
- +1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
- +2 ;
- DGPTUTL ;ALB/AS - PTF UTILITY ROUTINE ; 12/13/89@8
- +1 ;;5.3;Registration;**26**;Aug 13, 1993
- 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 SET DGZEC=$SELECT($DATA(^DPT(DFN,.36)):$PIECE(^(.36),U,1),1:"")
- SET DGZEC=$SELECT($DATA(^DIC(8,+DGZEC,0)):^(0),1:"")
- IF $PIECE(DGZEC,U,5)="N"
- SET DGX="N"
- GOTO DIE
- +2 IF DGADM<2860701
- SET DGX="X"
- GOTO DIE
- +3 IF $DATA(^DGPT(PTF,101))
- IF $DATA(^DIC(45.1,+^(101),0))
- IF $PIECE(^(0),"^",4)
- SET DGX="X"
- GOTO DIE
- +4 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
- +5 SET DGT=$PIECE($GET(^DGPT(PTF,70)),".")
- SET DGZ1=$$LST^DGMTU(DFN,DGT)
- if 'DGZ1
- GOTO AS
- +6 SET DGX=$SELECT('$DATA(DGZ1):"U",1:$PIECE(DGZ1,U,4))
- SET DGX=$SELECT(DGX="A":"AN","BN"[DGX:DGX,"CP"[DGX:"C",1:"U")
- if DGX'="N"
- GOTO DIE
- 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 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
- +2 IF DGZEC]""
- SET DGX="AN"
- GOTO DIE
- +3 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
