DGPTFCR ;ALB/JDS - CREATE IN PATIENT PTF RECORD ;Sep 22, 2020@16:34
;;5.3;Registration;**932,1020**;Aug 13, 1993;Build 11
;
EN D LO^DGUTL F DGDUMB=0:0 K DFN D SEL Q:'$D(DFN)
Q K %,D0,DQ,T,Y,X,DGDUMB Q
;
SEL ; -- pt select
W ! K DIC
S DIC(0)="AEQMZ",DIC="^DPT(",DIC("S")="I $D(^DGPM(""APTT1"",+Y))",DIC("A")="Select Patient: "
D ^DIC K DIC G SELQ:Y'>0 S DFN=+Y
;
; -- adm mvt select
; will change to use ^DGPM("ADFN") cross-reference when available
W !
S DIC(0)="EQZ",DIC="^DGPM(",DIC("S")="I $P(^(0),U,2)=1,'$P(^(0),U,26),'$D(^DGPT(+$P(^(0),U,16),0))",DIC("A")="Select Admission Date: "
D DFN^DGPMUTL K DIC G SELQ:Y'>0
;
N DGPMCA,DGPMAN,DGPMDN
S DGPMCA=+Y,DGPMAN=Y(0),DGPMDN=$S($D(^DGPM(+$P(DGPMAN,"^",17),0)):^(0),1:""),DGTY=$S($D(^DG(405.2,+$P(DGPMDN,"^",18),0)):$P(^(0),"^",8),1:0)
S Y=1 D RTY^DGPTUTL S Y=+DGPMAN
W !!?5,"Creating new PTF record..."
D CREATE I +Y<0 W *7,"unable to create record." G SELQ
S PTF=+Y,DR="[DG PTF ATTACH]",DIE="^DGPM(",DA=DGPMCA D ^DIE
W !?5,"record #",PTF," created.",!
SELQ ; -- clean-up
K DR,X,DA,DIE,DIC,DGTY,DGRTY,DGRTY0,PTF,I,J,Y,DQ,DG
Q
;
CREATE ; -- entry point to create a new PTF record
; input: DFN := pt number
; Y := admission d/t ^ fee record
; DGRTY := type of record (1-PTF ; 2-CENSUS)
; (PTF assumed if undefined)
; output: Y := ifn of ^DGPT
;
I $S('$D(DFN):1,'DFN:1,1:'Y) S Y=-1,Y(0)="" G CREATEQ
S DGPTDATA=U_Y,DIC="^DGPT(",DIC("DR")="[DG PTF CREATE PTF ENTRY]"
S DIC(0)="FLZ",X=DFN K DD,DO D FILE^DICN S Y=+Y
I $S('$D(DGRTY):1,1:DGRTY=1) N PTF K DA S (PTF,DA)=Y,DIE="^DGPT(",DR="[DG PTF POST CREATE]" D ^DIE:DA>0 S Y=PTF
CREATEQ K DA,DIC,DGPTDATA,DIE,DR Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTFCR 1735 printed Sep 23, 2025@20:28 Page 2
DGPTFCR ;ALB/JDS - CREATE IN PATIENT PTF RECORD ;Sep 22, 2020@16:34
+1 ;;5.3;Registration;**932,1020**;Aug 13, 1993;Build 11
+2 ;
EN DO LO^DGUTL
FOR DGDUMB=0:0
KILL DFN
DO SEL
if '$DATA(DFN)
QUIT
Q KILL %,D0,DQ,T,Y,X,DGDUMB
QUIT
+1 ;
SEL ; -- pt select
+1 WRITE !
KILL DIC
+2 SET DIC(0)="AEQMZ"
SET DIC="^DPT("
SET DIC("S")="I $D(^DGPM(""APTT1"",+Y))"
SET DIC("A")="Select Patient: "
+3 DO ^DIC
KILL DIC
if Y'>0
GOTO SELQ
SET DFN=+Y
+4 ;
+5 ; -- adm mvt select
+6 ; will change to use ^DGPM("ADFN") cross-reference when available
+7 WRITE !
+8 SET DIC(0)="EQZ"
SET DIC="^DGPM("
SET DIC("S")="I $P(^(0),U,2)=1,'$P(^(0),U,26),'$D(^DGPT(+$P(^(0),U,16),0))"
SET DIC("A")="Select Admission Date: "
+9 DO DFN^DGPMUTL
KILL DIC
if Y'>0
GOTO SELQ
+10 ;
+11 NEW DGPMCA,DGPMAN,DGPMDN
+12 SET DGPMCA=+Y
SET DGPMAN=Y(0)
SET DGPMDN=$SELECT($DATA(^DGPM(+$PIECE(DGPMAN,"^",17),0)):^(0),1:"")
SET DGTY=$SELECT($DATA(^DG(405.2,+$PIECE(DGPMDN,"^",18),0)):$PIECE(^(0),"^",8),1:0)
+13 SET Y=1
DO RTY^DGPTUTL
SET Y=+DGPMAN
+14 WRITE !!?5,"Creating new PTF record..."
+15 DO CREATE
IF +Y<0
WRITE *7,"unable to create record."
GOTO SELQ
+16 SET PTF=+Y
SET DR="[DG PTF ATTACH]"
SET DIE="^DGPM("
SET DA=DGPMCA
DO ^DIE
+17 WRITE !?5,"record #",PTF," created.",!
SELQ ; -- clean-up
+1 KILL DR,X,DA,DIE,DIC,DGTY,DGRTY,DGRTY0,PTF,I,J,Y,DQ,DG
+2 QUIT
+3 ;
CREATE ; -- entry point to create a new PTF record
+1 ; input: DFN := pt number
+2 ; Y := admission d/t ^ fee record
+3 ; DGRTY := type of record (1-PTF ; 2-CENSUS)
+4 ; (PTF assumed if undefined)
+5 ; output: Y := ifn of ^DGPT
+6 ;
+7 IF $SELECT('$DATA(DFN):1,'DFN:1,1:'Y)
SET Y=-1
SET Y(0)=""
GOTO CREATEQ
+8 SET DGPTDATA=U_Y
SET DIC="^DGPT("
SET DIC("DR")="[DG PTF CREATE PTF ENTRY]"
+9 SET DIC(0)="FLZ"
SET X=DFN
KILL DD,DO
DO FILE^DICN
SET Y=+Y
+10 IF $SELECT('$DATA(DGRTY):1,1:DGRTY=1)
NEW PTF
KILL DA
SET (PTF,DA)=Y
SET DIE="^DGPT("
SET DR="[DG PTF POST CREATE]"
if DA>0
DO ^DIE
SET Y=PTF
CREATEQ KILL DA,DIC,DGPTDATA,DIE,DR
QUIT
