DG53864P ;BP/DMR - POST INT TO ADD PRF
;;5.3;Reqistration;**864**;Aug 13, 1993;Build 16
;
;
; This rountine will create the new URGENT: ADDRESS AS FEMALE Patient Record Flag
; in the PRF NATIONAL FLAG file (#26.15). The routine can be deleted after the
; flag is installed.
;
EN ;
N DGPRF,DGMSG,DGFDA,DGFDAIEN,DGWP,DGTIU,DGMSG,DGERR,DGRESULT,DGLINE
;
S DGPRF="URGENT ADDRESS AS FEMALE"
S DGTIU="PATIENT RECORD FLAG CATEGORY I - URGENT ADDRESS AS FEMALE"
;
K DGERR,DGMSG
D CHK^DIE(26.15,.07,"E",DGTIU,.DGRESULT,"DGERR")
I $D(DGERR)>0 D Q
. D MSG^DIALOG("EA",.DGMSG,"","","DGERR")
. S DGLINE=$O(DGMSG(999999),-1)
. S DGMSG(DGLINE+1)="Please check that patch TIU*1.0*275 must be installed."
. S DGMSG(DGLINE+2)="Exiting install of the new national PRF flag"
. D MES^XPDUTL(.DGMSG)
;
I $D(^DGPF(26.15,"B",DGPRF))>0 D Q
. S DGMSG(1)="The 'URGENT ADDRESS AS FEMALE' PRF is already entered in the PRF"
. S DGMSG(2)="NATIONAL FLAG file, install will abort."
. D MES^XPDUTL(.DGMSG)
; Create entry in file #26.15
D BMES^XPDUTL("Installing new national PRF entry")
S DGFDA(1,26.15,"+1,",.01)=DGPRF
S DGFDA(1,26.15,"+1,",.02)="ACTIVE"
S DGFDA(1,26.15,"+1,",.03)="OTHER"
S DGFDA(1,26.15,"+1,",.04)="0"
S DGFDA(1,26.15,"+1,",.05)="0"
S DGFDA(1,26.15,"+1,",.06)=""
S DGFDA(1,26.15,"+1,",.07)=DGTIU
K DGERR,DGMSG
D UPDATE^DIE("E","DGFDA(1)","DGFDAIEN","DGERR")
I $D(DGERR)>0 D Q
. D MSG^DIALOG("EA",.DGMSG,"","","DGERR")
. D MES^XPDUTL(.DGMSG)
; Create description (word-processing) field
K DGERR,DGMSG
S DGWP(1,1)="This Patient Record Flag was established to ensure that a transgender"
S DGWP(1,2)="Veteran is addressed as Female per a court order agreement. This flag"
S DGWP(1,3)="cannot be used without approval of the Under Secretary for Health."
D WP^DIE(26.15,DGFDAIEN(1)_",",1,"A","DGWP(1)","DGERR")
I $D(DGERR) D Q
. D MSG^DIALOG("EA",.DGMSG,"","","DGERR")
. D MES^XPDUTL(.DGMSG)
;
D BMES^XPDUTL("Installation of new national PRF entry complete")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDG53864P 2059 printed Apr 09, 2024@21:44:23 Page 2
DG53864P ;BP/DMR - POST INT TO ADD PRF
+1 ;;5.3;Reqistration;**864**;Aug 13, 1993;Build 16
+2 ;
+3 ;
+4 ; This rountine will create the new URGENT: ADDRESS AS FEMALE Patient Record Flag
+5 ; in the PRF NATIONAL FLAG file (#26.15). The routine can be deleted after the
+6 ; flag is installed.
+7 ;
EN ;
+1 NEW DGPRF,DGMSG,DGFDA,DGFDAIEN,DGWP,DGTIU,DGMSG,DGERR,DGRESULT,DGLINE
+2 ;
+3 SET DGPRF="URGENT ADDRESS AS FEMALE"
+4 SET DGTIU="PATIENT RECORD FLAG CATEGORY I - URGENT ADDRESS AS FEMALE"
+5 ;
+6 KILL DGERR,DGMSG
+7 DO CHK^DIE(26.15,.07,"E",DGTIU,.DGRESULT,"DGERR")
+8 IF $DATA(DGERR)>0
Begin DoDot:1
+9 DO MSG^DIALOG("EA",.DGMSG,"","","DGERR")
+10 SET DGLINE=$ORDER(DGMSG(999999),-1)
+11 SET DGMSG(DGLINE+1)="Please check that patch TIU*1.0*275 must be installed."
+12 SET DGMSG(DGLINE+2)="Exiting install of the new national PRF flag"
+13 DO MES^XPDUTL(.DGMSG)
End DoDot:1
QUIT
+14 ;
+15 IF $DATA(^DGPF(26.15,"B",DGPRF))>0
Begin DoDot:1
+16 SET DGMSG(1)="The 'URGENT ADDRESS AS FEMALE' PRF is already entered in the PRF"
+17 SET DGMSG(2)="NATIONAL FLAG file, install will abort."
+18 DO MES^XPDUTL(.DGMSG)
End DoDot:1
QUIT
+19 ; Create entry in file #26.15
+20 DO BMES^XPDUTL("Installing new national PRF entry")
+21 SET DGFDA(1,26.15,"+1,",.01)=DGPRF
+22 SET DGFDA(1,26.15,"+1,",.02)="ACTIVE"
+23 SET DGFDA(1,26.15,"+1,",.03)="OTHER"
+24 SET DGFDA(1,26.15,"+1,",.04)="0"
+25 SET DGFDA(1,26.15,"+1,",.05)="0"
+26 SET DGFDA(1,26.15,"+1,",.06)=""
+27 SET DGFDA(1,26.15,"+1,",.07)=DGTIU
+28 KILL DGERR,DGMSG
+29 DO UPDATE^DIE("E","DGFDA(1)","DGFDAIEN","DGERR")
+30 IF $DATA(DGERR)>0
Begin DoDot:1
+31 DO MSG^DIALOG("EA",.DGMSG,"","","DGERR")
+32 DO MES^XPDUTL(.DGMSG)
End DoDot:1
QUIT
+33 ; Create description (word-processing) field
+34 KILL DGERR,DGMSG
+35 SET DGWP(1,1)="This Patient Record Flag was established to ensure that a transgender"
+36 SET DGWP(1,2)="Veteran is addressed as Female per a court order agreement. This flag"
+37 SET DGWP(1,3)="cannot be used without approval of the Under Secretary for Health."
+38 DO WP^DIE(26.15,DGFDAIEN(1)_",",1,"A","DGWP(1)","DGERR")
+39 IF $DATA(DGERR)
Begin DoDot:1
+40 DO MSG^DIALOG("EA",.DGMSG,"","","DGERR")
+41 DO MES^XPDUTL(.DGMSG)
End DoDot:1
QUIT
+42 ;
+43 DO BMES^XPDUTL("Installation of new national PRF entry complete")
+44 QUIT
