DGPFLMA2 ;ALB/KCL - PRF ASSIGNMENT LM PROTOCOL ACTIONS CONT. ; 6/12/06 12:46pm
;;5.3;Registration;**425,623,554,650,864,951**;Aug 13, 1993;Build 135
; Last edited: SHRPE/SGM - Nov 9, 2018 12:44
;
QUIT
; ICR# TYPE DESCRIPTION
;----- ---- -------------------------
; 2050 Sup ^DIALOG: BLD, MSG
; 2054 Sup $$OREF^DILF
; 2055 Sup $$EXTERNAL^DILFD
; 2056 Sup $$GET1^DIQ
; 2171 Sup ^XUAF4: $$NS, $$STA, $$TF
;10028 Sup EN^DIWE
;10103 Sup ^XLFDT: $$FMTE, $$NOW
;10116 Sup ^VALM1: FULL, PAUSE
;
AF ;Entry point for DGPF ASSIGN FLAG action protocol.
;
; Input:
; DGDFN - pointer to patient in PATIENT (#2) file
;
; Output:
; VALMBCK - 'R' = refresh screen
;
N DIC,DGWPROOT,DIWETXT,DIWESUB,DWLW,DWPK ;input vars for EN^DIWE call
N DGABORT ;abort flag for entering assignment narrative
N DGFAC ;pointer to INSTITUTION (#4) file
N DGOK ;ok flag for entering assignment narrative
N DGPFA ;assignment array
N DGPFAH ;assignment history array
N DGRDAT ;results of review date calculation
N DGRESULT ;result of STOALL api call
N DGERR ;if unable to add assignment
N DGPFERR ;if error returned from STOALL
N PRFIEN ;PRF IEN from file 26.15 dg*5.3*864
N PRFNAME ;PRF NAME (.01) field dg*5.3*864
;
;set screen to full scroll region
D FULL^VALM1
;
;quit if patient not selected
I '$G(DGDFN) D Q
. D BLD^DIALOG(261129,"Patient has not been selected.","","DGERR","F")
. D MSG^DIALOG("WE","","","","DGERR") W *7
. D PAUSE^VALM1
. S VALMBCK="R"
;
;is user's DUZ(2) an enabled Division for PRF ASSIGNMENT OWNERSHIP
I '$D(^DG(40.8,"APRF",+$G(DUZ(2)))) D Q
. D BLD^DIALOG(261129,"Your Division, "_$$STA^XUAF4($G(DUZ(2)))_", is not enabled for PRF Assignment Ownership.","","DGERR","F")
. D MSG^DIALOG("WE","","","","DGERR") W *7
. D PAUSE^VALM1
. S VALMBCK="R"
;
D ;drops out of DO block on assignment failure
. ;
. ;init assignment and history arrays
. K DGPFA,DGPFAH
. ;
. ;get patient DFN into assignment array
. S DGPFA("DFN")=$G(DGDFN)
. Q:'DGPFA("DFN")
. ;
. ;select flag for assignment
. S DGPFA("FLAG")=$$ANSWER^DGPFUT("Select a flag for this assignment","","26.13,.02")
. Q:(DGPFA("FLAG")'>0)
. ; Urgent Address is Female,check if user has programmer access dg*5.3*864.
. N PRFIEN,PRFNAME,PRFNAT
. S PRFNAT="" I $P(DGPFA("FLAG"),";",2)="DGPF(26.15," S PRFNAT=1
. S PRFIEN="" I PRFNAT=1 S PRFIEN=$P(DGPFA("FLAG"),";")
. S PRFNAME="" I PRFIEN'="" S PRFNAME=$$GET1^DIQ(26.15,PRFIEN,.01)
. I PRFNAME="URGENT ADDRESS AS FEMALE"&(DUZ("0")'="@") D Q
. . W !!!,"The URGENT ADDRESS AS FEMALE National Flag is limited to purposes"
. . W !,"authorized by the Undersecretary for Health only."
. . W !!!
. . D PAUSE^VALM1
. ;
. ;National ICN when Cat I assignment?
. I $P(DGPFA("FLAG"),U)["26.15",'$$MPIOK^DGPFUT(DGPFA("DFN")) D Q
. . W !!,"Unable to proceed with flag assignment..."
. . D BLD^DIALOG(261132,"","","DGERR","F")
. . D MSG^DIALOG("WE","","","","DGERR") W *7
. . D PAUSE^VALM1
. ;
. ;run query for Cat I assignments
. I $P(DGPFA("FLAG"),U)["26.15",$$GETSTAT^DGPFHLL1(DGDFN)'="C" D
. . N DGDIFF ; difference between pre and post query count
. . N DGFLGCNT ; total count of Cat I flags
. . N DGMSG ; temp array for messages
. . N DGPRECNT ; pre-query count of Cat I assignments
. . N DGPSTCNT ; post-query count of Cat I assignments
. . N L,X
. . ;
. . ;get count of current assignments
. . S (DGPRECNT,DGPSTCNT)=$$GETALL^DGPFAA(DGDFN,,,1)
. . ;
. . ;get total count of possible Category I flags
. . S DGFLGCNT=$$CNTRECS^DGPFUT1(26.15)
. . ;
. . ;stop if all flags are assigned
. . Q:DGPRECNT=DGFLGCNT
. . ;
. . ;execute the query...stop on failure
. . Q:'$$SNDQRY^DGPFHLS(DGDFN,1,.DGFAC)
. . ;
. . ;recheck current assignment count
. . S DGPSTCNT=$$GETALL^DGPFAA(DGDFN,,,1)
. . S DGDIFF=DGPSTCNT-DGPRECNT
. . S L=2,DGMSG("DIMSG",1)=" "
. . S X=" "_$S(DGDIFF:"One or more",1:"No")
. . S X=X_" Category I record flag assignments were "
. . S X=X_$S(DGDIFF:"returned",DGPSTCNT:"returned",1:"found.")
. . S DGMSG("DIMSG",2)=X
. . I DGDIFF!DGPSTCNT D
. . . S X=" from "_$P($$NS^XUAF4($G(DGFAC)),U)
. . . I DGDIFF S X=X_" and filed on your system."
. . . S DGMSG("DIMSG",3)=X,L=3
. . . Q
. . S L=L+1,DGMSG("DIMSG",L)=" "
. . D MSG^DIALOG("MW",,,,"DGMSG")
. . ;
. . ;re-build list when flag assignments have been added
. . I DGDIFF D BLDLIST^DGPFLMU(DGDFN)
. ;
. ;ok to add new assignment?
. I '$$ADDOK^DGPFAA2(DGPFA("DFN"),$P(DGPFA("FLAG"),U),"DGERR") D Q
. . W !!,"Unable to proceed with flag assignment..."
. . D MSG^DIALOG("WE","","",5,"DGERR")
. . D PAUSE^VALM1
. ;
. ;prompt for owner site
. S DGPFA("OWNER")=$$ANSWER^DGPFUT("Enter Owner Site",$$EXTERNAL^DILFD(26.13,.04,"",DUZ(2),"DGERR"),"P^4:EMZ","","I $D(^DG(40.8,""APRF"",+Y)),$$TF^XUAF4(+Y)")
. Q:(DGPFA("OWNER")'>0)
. ;
. ;prompt user for approved by person, quit if not selected
. S DGPFAH("APPRVBY")=$$ANSWER^DGPFUT("Approved By","","P^200:EMZ")
. Q:(DGPFAH("APPRVBY")'>0)
. ;
. ;have user enter assignment narrative text (required)
. S (DGABORT,DGOK)=0
. S DGWPROOT=$NA(^TMP($J,"DGPFNARR"))
. K @DGWPROOT
. F D Q:(DGOK!DGABORT)
. . N I,DGTX
. . S I="" ; init. I in order to prevent <UNDEFINED> error in LNQ^DIWE5 (part of EN^DIWE API call)
. . W !!,"Enter Narrative Text for this record flag assignment:" ;needed for line editor
. . S DIC=$$OREF^DILF(DGWPROOT)
. . S DIWETXT="Patient Record Flag - Assignment Narrative Text"
. . S DIWESUB="Assignment Narrative Text"
. . S DWLW=75 ;max # of chars allowed to be stored on WP global node
. . S DWPK=1 ;if line editor, don't join lines
. . D EN^DIWE
. . I $$CKWP^DGPFUT(DGWPROOT,.DGTX) S DGOK=1
. . E D
. . . W !,"Assignment Narrative Text is required!"_$C(7)
. . . I $D(DGTX) S I=0 F S I=$O(DGTX(I)) Q:'I W !,DGTX(I)
. . . I '$$CONTINUE^DGPFUT() S DGABORT=1
. . . Q
. . Q
. . ;
. ;quit if required assignment narrative not entered
. Q:$G(DGABORT)
. ;
. ;place assignment narrative text into assignment array
. M DGPFA("NARR")=@DGWPROOT K @DGWPROOT
. ;
. ;setup remaining assignment and history array nodes for filing
. S DGPFA("STATUS")=1 ; active
. S DGPFA("ORIGSITE")=DUZ(2) ; current user's login site
. S DGPFAH("ASSIGNDT")=$$NOW^XLFDT ; current date/time
. S DGPFAH("ACTION")=1 ; new assignment
. S DGPFAH("ENTERBY")=DUZ ; current user
. S DGPFAH("ORIGFAC")=+$$SITE^VASITE ; created by site
. S DGPFAH("COMMENT",1,0)="New record flag assignment."
. ;
. ;calculate the default review date
. S DGRDAT=$$GETRDT^DGPFAA3($P(DGPFA("FLAG"),U),DGPFAH("ASSIGNDT"))
. ;
. ;prompt for review date on valid default review date, otherwise null
. I DGRDAT>0 D
. . N X,XO
. . S X=$$FMTE^XLFDT(DGRDAT,"5D")
. . S XO="D^"_DT_":"_DGRDAT_":EX"
. . S DGPFA("REVIEWDT")=$$ANSWER^DGPFUT("Enter Review Date",X,XO)
. . Q
. E S DGPFA("REVIEWDT")=""
. Q:DGPFA("REVIEWDT")<0
. ;
. ;prompt for DBRS# ; DG*5.3*951
. D DBRS
. ;
. ;display flag assignment review screen to user
. D REVIEW^DGPFUT3(.DGPFA,.DGPFAH,"",XQY0,XQORNOD(0))
. ;
. Q:$$ANSWER^DGPFUT("Would you like to file this new record flag assignment","YES","Y")'>0
. ;
. ;file the assignment and history using STOALL api
. W !,"Filing the patient's new record flag assignment..."
. S DGRESULT=$$STOALL^DGPFAA(.DGPFA,.DGPFAH,.DGPFERR,"D")
. W !?5,"Assignment was "_$S(+$G(DGRESULT):"filed successfully.",1:"not filed successfully.")
. ;
. ;send HL7 message if adding an assignment to a CAT I flag
. I $G(DGRESULT),DGPFA("FLAG")["26.15",$$SNDORU^DGPFHLS(+DGRESULT) D
. . W !?5,"Message sent...updating patient's sites of record."
. ;
. D PAUSE^VALM1
. ;
. ;re-build list of flag assignments for patient
. D BLDLIST^DGPFLMU(DGDFN)
. Q
;
S VALMBCK="R"
;
Q
;---------------------------------------------------------------------
DBRS() ; DG*951
;Expects:
; DGPFA() = int^ext / PRFNAME = name of flag
; DGPFAH() = int
;
I $G(DGPFA("FLAG"))'["26.15," Q 1
I PRFNAME'="BEHAVIORAL" Q 1
;
N J,X,DBRS,OUT
;
; prompt for dbrs# /other
S OUT=0 F J=0:0 D Q:OUT
. N L,X,DGNM,DGXA,OTH
. ; build DIR("A") if appropriate
. S L=1,DGXA("A",1)=" Disruptive Behavior Report System Number"
. I $D(DBRS) D
. . N X,Y,SCR
. . S L=L+1
. . S DGXA("A",L)="The following DBRS Numbers have already been entered:"
. . S (X,Y)="" F S X=$O(DBRS(X)) Q:X="" D
. . . S Y=Y_$E(X_" ",1,20)
. . . I $L(Y)>60 S L=L+1,DGXA("A",L)=Y,Y=""
. . . Q
. . I $L(Y) S L=L+1,DGXA("A",L)=Y
. . S L=L+1,DGXA("A",L)=" "
. . Q
. S L=L+1,DGXA("A",L)=" "
. S DGXA="Enter DBRS Number"
. S SCR="26.131,.01Or^^S:X?.E1L.E X=$$UP^XLFSTR(X) K:$D(DBRS(X))!($$DBRSNO^DGPFUT6(X)<0) X"
. W ! S DGNM=$$ANSWER^DGPFUT(.DGXA,,SCR)
. I (DGNM<0)!("@"[DGNM) S OUT=1 Q
. ;
. S OTH=$$ANSWER^DGPFUT("DBRS Other",,"26.131,.02")
. S OTH=$S(OTH=-1:"",OTH="@":"",1:OTH)
. S DBRS(DGNM)=OTH
. Q
;
; set up DGPFA() and DGPFAH()
I $D(DBRS) D
. N J,L,Y,DATE,NM,OTH,SITE
. S DATE=+$E($$NOW^XLFDT,1,12),$P(DATE,U,2)=$$FMTE^XLFDT(DATE,"1Z")
. S SITE=$P($$SITE^VASITE,U,1,2)
. S (L,NM)=0 F J=0:0 S NM=$O(DBRS(NM)) Q:NM="" D
. . S L=L+1
. . S OTH=DBRS(NM)
. . S DGPFA("DBRS#",L)=NM_U_NM
. . S DGPFA("DBRS OTHER",L)=OTH_U_OTH
. . S DGPFA("DBRS DATE",L)=DATE
. . S DGPFA("DBRS SITE",L)=SITE
. . S DGPFAH("DBRS",L)=NM_U_OTH_U_(+DATE)_"^A^"_(+SITE)
. . ; all five piece are internal FM format
. . Q
. Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPFLMA2 9765 printed Apr 09, 2024@21:53:32 Page 2
DGPFLMA2 ;ALB/KCL - PRF ASSIGNMENT LM PROTOCOL ACTIONS CONT. ; 6/12/06 12:46pm
+1 ;;5.3;Registration;**425,623,554,650,864,951**;Aug 13, 1993;Build 135
+2 ; Last edited: SHRPE/SGM - Nov 9, 2018 12:44
+3 ;
+4 QUIT
+5 ; ICR# TYPE DESCRIPTION
+6 ;----- ---- -------------------------
+7 ; 2050 Sup ^DIALOG: BLD, MSG
+8 ; 2054 Sup $$OREF^DILF
+9 ; 2055 Sup $$EXTERNAL^DILFD
+10 ; 2056 Sup $$GET1^DIQ
+11 ; 2171 Sup ^XUAF4: $$NS, $$STA, $$TF
+12 ;10028 Sup EN^DIWE
+13 ;10103 Sup ^XLFDT: $$FMTE, $$NOW
+14 ;10116 Sup ^VALM1: FULL, PAUSE
+15 ;
AF ;Entry point for DGPF ASSIGN FLAG action protocol.
+1 ;
+2 ; Input:
+3 ; DGDFN - pointer to patient in PATIENT (#2) file
+4 ;
+5 ; Output:
+6 ; VALMBCK - 'R' = refresh screen
+7 ;
+8 ;input vars for EN^DIWE call
NEW DIC,DGWPROOT,DIWETXT,DIWESUB,DWLW,DWPK
+9 ;abort flag for entering assignment narrative
NEW DGABORT
+10 ;pointer to INSTITUTION (#4) file
NEW DGFAC
+11 ;ok flag for entering assignment narrative
NEW DGOK
+12 ;assignment array
NEW DGPFA
+13 ;assignment history array
NEW DGPFAH
+14 ;results of review date calculation
NEW DGRDAT
+15 ;result of STOALL api call
NEW DGRESULT
+16 ;if unable to add assignment
NEW DGERR
+17 ;if error returned from STOALL
NEW DGPFERR
+18 ;PRF IEN from file 26.15 dg*5.3*864
NEW PRFIEN
+19 ;PRF NAME (.01) field dg*5.3*864
NEW PRFNAME
+20 ;
+21 ;set screen to full scroll region
+22 DO FULL^VALM1
+23 ;
+24 ;quit if patient not selected
+25 IF '$GET(DGDFN)
Begin DoDot:1
+26 DO BLD^DIALOG(261129,"Patient has not been selected.","","DGERR","F")
+27 DO MSG^DIALOG("WE","","","","DGERR")
WRITE *7
+28 DO PAUSE^VALM1
+29 SET VALMBCK="R"
End DoDot:1
QUIT
+30 ;
+31 ;is user's DUZ(2) an enabled Division for PRF ASSIGNMENT OWNERSHIP
+32 IF '$DATA(^DG(40.8,"APRF",+$GET(DUZ(2))))
Begin DoDot:1
+33 DO BLD^DIALOG(261129,"Your Division, "_$$STA^XUAF4($GET(DUZ(2)))_", is not enabled for PRF Assignment Ownership.","","DGERR","F")
+34 DO MSG^DIALOG("WE","","","","DGERR")
WRITE *7
+35 DO PAUSE^VALM1
+36 SET VALMBCK="R"
End DoDot:1
QUIT
+37 ;
+38 ;drops out of DO block on assignment failure
Begin DoDot:1
+39 ;
+40 ;init assignment and history arrays
+41 KILL DGPFA,DGPFAH
+42 ;
+43 ;get patient DFN into assignment array
+44 SET DGPFA("DFN")=$GET(DGDFN)
+45 if 'DGPFA("DFN")
QUIT
+46 ;
+47 ;select flag for assignment
+48 SET DGPFA("FLAG")=$$ANSWER^DGPFUT("Select a flag for this assignment","","26.13,.02")
+49 if (DGPFA("FLAG")'>0)
QUIT
+50 ; Urgent Address is Female,check if user has programmer access dg*5.3*864.
+51 NEW PRFIEN,PRFNAME,PRFNAT
+52 SET PRFNAT=""
IF $PIECE(DGPFA("FLAG"),";",2)="DGPF(26.15,"
SET PRFNAT=1
+53 SET PRFIEN=""
IF PRFNAT=1
SET PRFIEN=$PIECE(DGPFA("FLAG"),";")
+54 SET PRFNAME=""
IF PRFIEN'=""
SET PRFNAME=$$GET1^DIQ(26.15,PRFIEN,.01)
+55 IF PRFNAME="URGENT ADDRESS AS FEMALE"&(DUZ("0")'="@")
Begin DoDot:2
+56 WRITE !!!,"The URGENT ADDRESS AS FEMALE National Flag is limited to purposes"
+57 WRITE !,"authorized by the Undersecretary for Health only."
+58 WRITE !!!
+59 DO PAUSE^VALM1
End DoDot:2
QUIT
+60 ;
+61 ;National ICN when Cat I assignment?
+62 IF $PIECE(DGPFA("FLAG"),U)["26.15"
IF '$$MPIOK^DGPFUT(DGPFA("DFN"))
Begin DoDot:2
+63 WRITE !!,"Unable to proceed with flag assignment..."
+64 DO BLD^DIALOG(261132,"","","DGERR","F")
+65 DO MSG^DIALOG("WE","","","","DGERR")
WRITE *7
+66 DO PAUSE^VALM1
End DoDot:2
QUIT
+67 ;
+68 ;run query for Cat I assignments
+69 IF $PIECE(DGPFA("FLAG"),U)["26.15"
IF $$GETSTAT^DGPFHLL1(DGDFN)'="C"
Begin DoDot:2
+70 ; difference between pre and post query count
NEW DGDIFF
+71 ; total count of Cat I flags
NEW DGFLGCNT
+72 ; temp array for messages
NEW DGMSG
+73 ; pre-query count of Cat I assignments
NEW DGPRECNT
+74 ; post-query count of Cat I assignments
NEW DGPSTCNT
+75 NEW L,X
+76 ;
+77 ;get count of current assignments
+78 SET (DGPRECNT,DGPSTCNT)=$$GETALL^DGPFAA(DGDFN,,,1)
+79 ;
+80 ;get total count of possible Category I flags
+81 SET DGFLGCNT=$$CNTRECS^DGPFUT1(26.15)
+82 ;
+83 ;stop if all flags are assigned
+84 if DGPRECNT=DGFLGCNT
QUIT
+85 ;
+86 ;execute the query...stop on failure
+87 if '$$SNDQRY^DGPFHLS(DGDFN,1,.DGFAC)
QUIT
+88 ;
+89 ;recheck current assignment count
+90 SET DGPSTCNT=$$GETALL^DGPFAA(DGDFN,,,1)
+91 SET DGDIFF=DGPSTCNT-DGPRECNT
+92 SET L=2
SET DGMSG("DIMSG",1)=" "
+93 SET X=" "_$SELECT(DGDIFF:"One or more",1:"No")
+94 SET X=X_" Category I record flag assignments were "
+95 SET X=X_$SELECT(DGDIFF:"returned",DGPSTCNT:"returned",1:"found.")
+96 SET DGMSG("DIMSG",2)=X
+97 IF DGDIFF!DGPSTCNT
Begin DoDot:3
+98 SET X=" from "_$PIECE($$NS^XUAF4($GET(DGFAC)),U)
+99 IF DGDIFF
SET X=X_" and filed on your system."
+100 SET DGMSG("DIMSG",3)=X
SET L=3
+101 QUIT
End DoDot:3
+102 SET L=L+1
SET DGMSG("DIMSG",L)=" "
+103 DO MSG^DIALOG("MW",,,,"DGMSG")
+104 ;
+105 ;re-build list when flag assignments have been added
+106 IF DGDIFF
DO BLDLIST^DGPFLMU(DGDFN)
End DoDot:2
+107 ;
+108 ;ok to add new assignment?
+109 IF '$$ADDOK^DGPFAA2(DGPFA("DFN"),$PIECE(DGPFA("FLAG"),U),"DGERR")
Begin DoDot:2
+110 WRITE !!,"Unable to proceed with flag assignment..."
+111 DO MSG^DIALOG("WE","","",5,"DGERR")
+112 DO PAUSE^VALM1
End DoDot:2
QUIT
+113 ;
+114 ;prompt for owner site
+115 SET DGPFA("OWNER")=$$ANSWER^DGPFUT("Enter Owner Site",$$EXTERNAL^DILFD(26.13,.04,"",DUZ(2),"DGERR"),"P^4:EMZ","","I $D(^DG(40.8,""APRF"",+Y)),$$TF^XUAF4(+Y)")
+116 if (DGPFA("OWNER")'>0)
QUIT
+117 ;
+118 ;prompt user for approved by person, quit if not selected
+119 SET DGPFAH("APPRVBY")=$$ANSWER^DGPFUT("Approved By","","P^200:EMZ")
+120 if (DGPFAH("APPRVBY")'>0)
QUIT
+121 ;
+122 ;have user enter assignment narrative text (required)
+123 SET (DGABORT,DGOK)=0
+124 SET DGWPROOT=$NAME(^TMP($JOB,"DGPFNARR"))
+125 KILL @DGWPROOT
+126 FOR
Begin DoDot:2
+127 NEW I,DGTX
+128 ; init. I in order to prevent <UNDEFINED> error in LNQ^DIWE5 (part of EN^DIWE API call)
SET I=""
+129 ;needed for line editor
WRITE !!,"Enter Narrative Text for this record flag assignment:"
+130 SET DIC=$$OREF^DILF(DGWPROOT)
+131 SET DIWETXT="Patient Record Flag - Assignment Narrative Text"
+132 SET DIWESUB="Assignment Narrative Text"
+133 ;max # of chars allowed to be stored on WP global node
SET DWLW=75
+134 ;if line editor, don't join lines
SET DWPK=1
+135 DO EN^DIWE
+136 IF $$CKWP^DGPFUT(DGWPROOT,.DGTX)
SET DGOK=1
+137 IF '$TEST
Begin DoDot:3
+138 WRITE !,"Assignment Narrative Text is required!"_$CHAR(7)
+139 IF $DATA(DGTX)
SET I=0
FOR
SET I=$ORDER(DGTX(I))
if 'I
QUIT
WRITE !,DGTX(I)
+140 IF '$$CONTINUE^DGPFUT()
SET DGABORT=1
+141 QUIT
End DoDot:3
+142 QUIT
+143 ;
End DoDot:2
if (DGOK!DGABORT)
QUIT
+144 ;quit if required assignment narrative not entered
+145 if $GET(DGABORT)
QUIT
+146 ;
+147 ;place assignment narrative text into assignment array
+148 MERGE DGPFA("NARR")=@DGWPROOT
KILL @DGWPROOT
+149 ;
+150 ;setup remaining assignment and history array nodes for filing
+151 ; active
SET DGPFA("STATUS")=1
+152 ; current user's login site
SET DGPFA("ORIGSITE")=DUZ(2)
+153 ; current date/time
SET DGPFAH("ASSIGNDT")=$$NOW^XLFDT
+154 ; new assignment
SET DGPFAH("ACTION")=1
+155 ; current user
SET DGPFAH("ENTERBY")=DUZ
+156 ; created by site
SET DGPFAH("ORIGFAC")=+$$SITE^VASITE
+157 SET DGPFAH("COMMENT",1,0)="New record flag assignment."
+158 ;
+159 ;calculate the default review date
+160 SET DGRDAT=$$GETRDT^DGPFAA3($PIECE(DGPFA("FLAG"),U),DGPFAH("ASSIGNDT"))
+161 ;
+162 ;prompt for review date on valid default review date, otherwise null
+163 IF DGRDAT>0
Begin DoDot:2
+164 NEW X,XO
+165 SET X=$$FMTE^XLFDT(DGRDAT,"5D")
+166 SET XO="D^"_DT_":"_DGRDAT_":EX"
+167 SET DGPFA("REVIEWDT")=$$ANSWER^DGPFUT("Enter Review Date",X,XO)
+168 QUIT
End DoDot:2
+169 IF '$TEST
SET DGPFA("REVIEWDT")=""
+170 if DGPFA("REVIEWDT")<0
QUIT
+171 ;
+172 ;prompt for DBRS# ; DG*5.3*951
+173 DO DBRS
+174 ;
+175 ;display flag assignment review screen to user
+176 DO REVIEW^DGPFUT3(.DGPFA,.DGPFAH,"",XQY0,XQORNOD(0))
+177 ;
+178 if $$ANSWER^DGPFUT("Would you like to file this new record flag assignment","YES","Y")'>0
QUIT
+179 ;
+180 ;file the assignment and history using STOALL api
+181 WRITE !,"Filing the patient's new record flag assignment..."
+182 SET DGRESULT=$$STOALL^DGPFAA(.DGPFA,.DGPFAH,.DGPFERR,"D")
+183 WRITE !?5,"Assignment was "_$SELECT(+$GET(DGRESULT):"filed successfully.",1:"not filed successfully.")
+184 ;
+185 ;send HL7 message if adding an assignment to a CAT I flag
+186 IF $GET(DGRESULT)
IF DGPFA("FLAG")["26.15"
IF $$SNDORU^DGPFHLS(+DGRESULT)
Begin DoDot:2
+187 WRITE !?5,"Message sent...updating patient's sites of record."
End DoDot:2
+188 ;
+189 DO PAUSE^VALM1
+190 ;
+191 ;re-build list of flag assignments for patient
+192 DO BLDLIST^DGPFLMU(DGDFN)
+193 QUIT
End DoDot:1
+194 ;
+195 SET VALMBCK="R"
+196 ;
+197 QUIT
+198 ;---------------------------------------------------------------------
DBRS() ; DG*951
+1 ;Expects:
+2 ; DGPFA() = int^ext / PRFNAME = name of flag
+3 ; DGPFAH() = int
+4 ;
+5 IF $GET(DGPFA("FLAG"))'["26.15,"
QUIT 1
+6 IF PRFNAME'="BEHAVIORAL"
QUIT 1
+7 ;
+8 NEW J,X,DBRS,OUT
+9 ;
+10 ; prompt for dbrs# /other
+11 SET OUT=0
FOR J=0:0
Begin DoDot:1
+12 NEW L,X,DGNM,DGXA,OTH
+13 ; build DIR("A") if appropriate
+14 SET L=1
SET DGXA("A",1)=" Disruptive Behavior Report System Number"
+15 IF $DATA(DBRS)
Begin DoDot:2
+16 NEW X,Y,SCR
+17 SET L=L+1
+18 SET DGXA("A",L)="The following DBRS Numbers have already been entered:"
+19 SET (X,Y)=""
FOR
SET X=$ORDER(DBRS(X))
if X=""
QUIT
Begin DoDot:3
+20 SET Y=Y_$EXTRACT(X_" ",1,20)
+21 IF $LENGTH(Y)>60
SET L=L+1
SET DGXA("A",L)=Y
SET Y=""
+22 QUIT
End DoDot:3
+23 IF $LENGTH(Y)
SET L=L+1
SET DGXA("A",L)=Y
+24 SET L=L+1
SET DGXA("A",L)=" "
+25 QUIT
End DoDot:2
+26 SET L=L+1
SET DGXA("A",L)=" "
+27 SET DGXA="Enter DBRS Number"
+28 SET SCR="26.131,.01Or^^S:X?.E1L.E X=$$UP^XLFSTR(X) K:$D(DBRS(X))!($$DBRSNO^DGPFUT6(X)<0) X"
+29 WRITE !
SET DGNM=$$ANSWER^DGPFUT(.DGXA,,SCR)
+30 IF (DGNM<0)!("@"[DGNM)
SET OUT=1
QUIT
+31 ;
+32 SET OTH=$$ANSWER^DGPFUT("DBRS Other",,"26.131,.02")
+33 SET OTH=$SELECT(OTH=-1:"",OTH="@":"",1:OTH)
+34 SET DBRS(DGNM)=OTH
+35 QUIT
End DoDot:1
if OUT
QUIT
+36 ;
+37 ; set up DGPFA() and DGPFAH()
+38 IF $DATA(DBRS)
Begin DoDot:1
+39 NEW J,L,Y,DATE,NM,OTH,SITE
+40 SET DATE=+$EXTRACT($$NOW^XLFDT,1,12)
SET $PIECE(DATE,U,2)=$$FMTE^XLFDT(DATE,"1Z")
+41 SET SITE=$PIECE($$SITE^VASITE,U,1,2)
+42 SET (L,NM)=0
FOR J=0:0
SET NM=$ORDER(DBRS(NM))
if NM=""
QUIT
Begin DoDot:2
+43 SET L=L+1
+44 SET OTH=DBRS(NM)
+45 SET DGPFA("DBRS#",L)=NM_U_NM
+46 SET DGPFA("DBRS OTHER",L)=OTH_U_OTH
+47 SET DGPFA("DBRS DATE",L)=DATE
+48 SET DGPFA("DBRS SITE",L)=SITE
+49 SET DGPFAH("DBRS",L)=NM_U_OTH_U_(+DATE)_"^A^"_(+SITE)
+50 ; all five piece are internal FM format
+51 QUIT
End DoDot:2
+52 QUIT
End DoDot:1
+53 QUIT
