DGRPLE ;WAS/ERC/RMM,ALB/CKN - REGISTRATION EDITS OF PURPLE HEART FIELDS ; 11/22/05 4:13pm
;;5.3;PIMS;**314,343,377,431,653,688,1015,1016**;JUN 30, 2012;Build 20
;
DIV() ;Get Institution Name
;If site is multi-divisional then ask user for division
;
; DBIA: #10112 - supported API $$SITE^VASITE and $$PRIM^VASITE
; for retrieving Institution name
;
; Input: none
;
; Output: DGNAM - Institution name
;
N DGDIV,DGSTN,DGNAM
S DGDIV=$S($D(^DG(40.8,"B")):$$MULTDIV,1:$$PRIM^VASITE)
S DGSTN=$$SITE^VASITE(,DGDIV)
S DGNAM=$S($P(DGSTN,U,2)]"":$P(DGSTN,U,2),1:"")
Q DGNAM
;
MULTDIV() ;User selects from active divisions
;
; Input: none
;
; Output:
; Function return value - Division IEN
;
N DIR,X,Y
S DIR(0)="PA^40.8:EM"
S DIR("A")="Enter your division: "
S DIR("S")="I $$SITE^VASITE(,+Y)>0"
D ^DIR
Q +Y
;
EDITPOW(DG1,DG2,DG3,DG4,DGDFN) ;entry from enrollment for HEC updates
; DGDFN - Patient File IEN
; DG1 - POW Indicator
; DG2 - POW Confinement Location
; DG3 - POW From Date
; DG4 - POW To Date
; Update POW data from HEC - DG*5.3*653
N DATA,DGENDA,ERROR,CURPOW,POW
S DGENDA=DGDFN
S CURPOW=$G(^DPT(DGDFN,.52))
S POW(.525)=$P(CURPOW,"^",5) ;Current POW indicator
S POW(.529)=$P(CURPOW,"^",9) ;Current POW verified status
S DATA(.525)=$G(DG1)
;If Current POW Verified Status is null,
;OR Current POW Verified Status is not null and incoming POW indicator is different than current POW indicator,
;set POW Verified Status to current Date/Time.
I (POW(.529)="")!((POW(.529)'="")&(DG1'=POW(.525))) S DATA(.529)=$$NOW^XLFDT()
;Remove the values in database if POW Indicator is NO
;otherwise update new values
S DATA(.526)=$S(DG1="N":"@",1:DG2)
S DATA(.527)=$S(DG1="N":"@",1:DG3)
S DATA(.528)=$S(DG1="N":"@",1:DG4)
I '$$UPD^DGENDBS(2,.DGENDA,.DATA,.ERROR) D
. D ADDMSG^DGENUPL3(.MSGS,"Unable to update POW Data.",1)
K DATA,DGENDA,ERROR,DG1,DG2,DG3,DG4
Q
;
EDITPH(DG1,DG2,DG3,DGDFN) ;entry from enrollment for HEC updates
; DGDFN - Patient File IEN
; DG1 - PH Indicator
; DG2 - PH Status
; DG3 - PH Remarks
;
N DATA,DGENDA,ERROR,DGUSER,DGPHARR,%
S DGENDA=DGDFN
S (DG(1),DATA(.531))=DG1
S (DG(2),DATA(.532))=$S(DG1="N":"",1:DG2)
S (DG(3),DATA(.533))=$S(DG1="Y":"",1:DG3)
I '$$UPD^DGENDBS(2,.DGENDA,.DATA,.ERROR) D
.D ADDMSG^DGENUPL3(.MSGS,"Unable to update Purple Heart Data.",1)
K DATA,DGENDA,ERROR
; If the Database Server Failed, Quit.
Q:'$D(^DPT(DGDFN,.53))
S DGUSER="HEC User",DGPHARR=^DPT(DGDFN,.53)
; If nothing was changed, don't update the history, Quit.
Q:'$$CHANGE(DG(1),DG(2),DG(3),DGDFN)
;
D NOW^%DTC
S DATA(.01)=%,DATA(1)=DG(1),DATA(2)=DG(2),DATA(3)=DG(3)
S DATA(4)=DGUSER,DGENDA(1)=DGDFN
I '$$ADD^DGENDBS(2.0534,.DGENDA,.DATA,.ERROR) D
.D ADDMSG^DGENUPL3(.MSGS,"Unable to update Purple Heart History.",1)
K DATA,DGENDA,ERROR
;
Q
;
EDITPH1(DGUSER) ;
; Input: DGUSER - Person filing Purple Heart changes
;
; Output: none
;
S DGUSER=$G(DGUSER,$P(^VA(200,DUZ,0),U))
NEW DGPHARR,DG,DGX
S DGPHARR=^DPT(DFN,.53)
;REDIE will ensure there is a STATUS only if indicator is
;'yes' and a REMARK only if indicator is 'no'
I $P(DGPHARR,U)="Y",($P(DGPHARR,U,3)]"") D REDIE(3)
I $P(DGPHARR,U)="N",($P(DGPHARR,U,2)]"") D REDIE(2)
F DGX=1:1:3 S DG(DGX)=$P(DGPHARR,U,DGX)
I $$CHANGE(DG(1),DG(2),DG(3),DFN) D EDITPH2(DG(1),DG(2),DG(3),DGUSER)
Q
;
EDITPH2(DG1,DG2,DG3,DG4) ;stuff PH values into the PH multiple of file #2
S DFN=DA
N DA,DIC,DIE
S DIC="^DPT("_DFN_",""PH"","
S DA(1)=DFN
D NOW^%DTC S X=%
S DIC(0)="L"
S DIC("DR")="1///^S X=$G(DG1);2///^S X=$G(DG2);3///^S X=$G(DG3);4///^S X=$G(DG4)"
D ^DIC
Q
;
REDIE(DGPCE) ; make sure value in PH Status and PH Remarks consistent
; with value of PH Indicator
N DA,DIE,DR
S DIE="^DPT(",DR=$S($G(DGPCE)=2:.532,1:.533)_"///^S X=""@"""
S DA=DFN
D ^DIE
S DGPHARR=^DPT(DFN,.53)
Q
;
CHANGE(DGPH1,DGPH2,DGPH3,DGPHDFN) ;Check to see if the entry has changed
; Input:
; DGPH1 - PH Indicator
; DGPH2 - PH Status
; DGPH3 - PH Remarks
; DGPHDFN- Patient file IEN
;
; Output: none
;
; Return: DGCHG = 1 - Change in any of the input values has occurred
; DGCHG = 0 - No change
;
N DGCHG ;Return value
N DGARR ;Array containing last values from audit
N DGPHVAL ;Merged array of DGARR
N DGERR ;Error root for DIQ
N DGIEN ;IEN of last audit value
N DGFILE ;Purple Heart Multiple
N DGI ;Index counter
;
K DGPHINC
S DGCHG=0
S DGFILE=2.0534
S DGIEN=$O(^DPT(DGPHDFN,"PH","B"),-1)
I DGIEN="" S DGCHG=1 G AUDITQ
D GETS^DIQ(DGFILE,DGIEN_","_DGPHDFN_",","1;2;3","I","DGARR","DGERR")
I $D(DGERR) S DGCHG=1 G AUDITQ
M DGPHVAL=DGARR(DGFILE,DGIEN_","_DGPHDFN_",")
F DGI=1:1:3 I @("DGPH"_DGI)'=DGPHVAL(DGI,"I") D
. S DGCHG=1
. I DGI=1 D ; PH INDICATOR has changed
. . I DGPH1="N",DGPHVAL(DGI,"I")="Y" S DGPHINC=1 ; Package Variable to note PH Indicator has changed
AUDITQ Q DGCHG
DGRPLE ;WAS/ERC/RMM,ALB/CKN - REGISTRATION EDITS OF PURPLE HEART FIELDS ; 11/22/05 4:13pm
+1 ;;5.3;PIMS;**314,343,377,431,653,688,1015,1016**;JUN 30, 2012;Build 20
+2 ;
DIV() ;Get Institution Name
+1 ;If site is multi-divisional then ask user for division
+2 ;
+3 ; DBIA: #10112 - supported API $$SITE^VASITE and $$PRIM^VASITE
+4 ; for retrieving Institution name
+5 ;
+6 ; Input: none
+7 ;
+8 ; Output: DGNAM - Institution name
+9 ;
+10 NEW DGDIV,DGSTN,DGNAM
+11 SET DGDIV=$SELECT($DATA(^DG(40.8,"B")):$$MULTDIV,1:$$PRIM^VASITE)
+12 SET DGSTN=$$SITE^VASITE(,DGDIV)
+13 SET DGNAM=$SELECT($PIECE(DGSTN,U,2)]"":$PIECE(DGSTN,U,2),1:"")
+14 QUIT DGNAM
+15 ;
MULTDIV() ;User selects from active divisions
+1 ;
+2 ; Input: none
+3 ;
+4 ; Output:
+5 ; Function return value - Division IEN
+6 ;
+7 NEW DIR,X,Y
+8 SET DIR(0)="PA^40.8:EM"
+9 SET DIR("A")="Enter your division: "
+10 SET DIR("S")="I $$SITE^VASITE(,+Y)>0"
+11 DO ^DIR
+12 QUIT +Y
+13 ;
EDITPOW(DG1,DG2,DG3,DG4,DGDFN) ;entry from enrollment for HEC updates
+1 ; DGDFN - Patient File IEN
+2 ; DG1 - POW Indicator
+3 ; DG2 - POW Confinement Location
+4 ; DG3 - POW From Date
+5 ; DG4 - POW To Date
+6 ; Update POW data from HEC - DG*5.3*653
+7 NEW DATA,DGENDA,ERROR,CURPOW,POW
+8 SET DGENDA=DGDFN
+9 SET CURPOW=$GET(^DPT(DGDFN,.52))
+10 ;Current POW indicator
SET POW(.525)=$PIECE(CURPOW,"^",5)
+11 ;Current POW verified status
SET POW(.529)=$PIECE(CURPOW,"^",9)
+12 SET DATA(.525)=$GET(DG1)
+13 ;If Current POW Verified Status is null,
+14 ;OR Current POW Verified Status is not null and incoming POW indicator is different than current POW indicator,
+15 ;set POW Verified Status to current Date/Time.
+16 IF (POW(.529)="")!((POW(.529)'="")&(DG1'=POW(.525)))
SET DATA(.529)=$$NOW^XLFDT()
+17 ;Remove the values in database if POW Indicator is NO
+18 ;otherwise update new values
+19 SET DATA(.526)=$SELECT(DG1="N":"@",1:DG2)
+20 SET DATA(.527)=$SELECT(DG1="N":"@",1:DG3)
+21 SET DATA(.528)=$SELECT(DG1="N":"@",1:DG4)
+22 IF '$$UPD^DGENDBS(2,.DGENDA,.DATA,.ERROR)
Begin DoDot:1
+23 DO ADDMSG^DGENUPL3(.MSGS,"Unable to update POW Data.",1)
End DoDot:1
+24 KILL DATA,DGENDA,ERROR,DG1,DG2,DG3,DG4
+25 QUIT
+26 ;
EDITPH(DG1,DG2,DG3,DGDFN) ;entry from enrollment for HEC updates
+1 ; DGDFN - Patient File IEN
+2 ; DG1 - PH Indicator
+3 ; DG2 - PH Status
+4 ; DG3 - PH Remarks
+5 ;
+6 NEW DATA,DGENDA,ERROR,DGUSER,DGPHARR,%
+7 SET DGENDA=DGDFN
+8 SET (DG(1),DATA(.531))=DG1
+9 SET (DG(2),DATA(.532))=$SELECT(DG1="N":"",1:DG2)
+10 SET (DG(3),DATA(.533))=$SELECT(DG1="Y":"",1:DG3)
+11 IF '$$UPD^DGENDBS(2,.DGENDA,.DATA,.ERROR)
Begin DoDot:1
+12 DO ADDMSG^DGENUPL3(.MSGS,"Unable to update Purple Heart Data.",1)
End DoDot:1
+13 KILL DATA,DGENDA,ERROR
+14 ; If the Database Server Failed, Quit.
+15 IF '$DATA(^DPT(DGDFN,.53))
QUIT
+16 SET DGUSER="HEC User"
SET DGPHARR=^DPT(DGDFN,.53)
+17 ; If nothing was changed, don't update the history, Quit.
+18 IF '$$CHANGE(DG(1),DG(2),DG(3),DGDFN)
QUIT
+19 ;
+20 DO NOW^%DTC
+21 SET DATA(.01)=%
SET DATA(1)=DG(1)
SET DATA(2)=DG(2)
SET DATA(3)=DG(3)
+22 SET DATA(4)=DGUSER
SET DGENDA(1)=DGDFN
+23 IF '$$ADD^DGENDBS(2.0534,.DGENDA,.DATA,.ERROR)
Begin DoDot:1
+24 DO ADDMSG^DGENUPL3(.MSGS,"Unable to update Purple Heart History.",1)
End DoDot:1
+25 KILL DATA,DGENDA,ERROR
+26 ;
+27 QUIT
+28 ;
EDITPH1(DGUSER) ;
+1 ; Input: DGUSER - Person filing Purple Heart changes
+2 ;
+3 ; Output: none
+4 ;
+5 SET DGUSER=$GET(DGUSER,$PIECE(^VA(200,DUZ,0),U))
+6 NEW DGPHARR,DG,DGX
+7 SET DGPHARR=^DPT(DFN,.53)
+8 ;REDIE will ensure there is a STATUS only if indicator is
+9 ;'yes' and a REMARK only if indicator is 'no'
+10 IF $PIECE(DGPHARR,U)="Y"
IF ($PIECE(DGPHARR,U,3)]"")
DO REDIE(3)
+11 IF $PIECE(DGPHARR,U)="N"
IF ($PIECE(DGPHARR,U,2)]"")
DO REDIE(2)
+12 FOR DGX=1:1:3
SET DG(DGX)=$PIECE(DGPHARR,U,DGX)
+13 IF $$CHANGE(DG(1),DG(2),DG(3),DFN)
DO EDITPH2(DG(1),DG(2),DG(3),DGUSER)
+14 QUIT
+15 ;
EDITPH2(DG1,DG2,DG3,DG4) ;stuff PH values into the PH multiple of file #2
+1 SET DFN=DA
+2 NEW DA,DIC,DIE
+3 SET DIC="^DPT("_DFN_",""PH"","
+4 SET DA(1)=DFN
+5 DO NOW^%DTC
SET X=%
+6 SET DIC(0)="L"
+7 SET DIC("DR")="1///^S X=$G(DG1);2///^S X=$G(DG2);3///^S X=$G(DG3);4///^S X=$G(DG4)"
+8 DO ^DIC
+9 QUIT
+10 ;
REDIE(DGPCE) ; make sure value in PH Status and PH Remarks consistent
+1 ; with value of PH Indicator
+2 NEW DA,DIE,DR
+3 SET DIE="^DPT("
SET DR=$SELECT($GET(DGPCE)=2:.532,1:.533)_"///^S X=""@"""
+4 SET DA=DFN
+5 DO ^DIE
+6 SET DGPHARR=^DPT(DFN,.53)
+7 QUIT
+8 ;
CHANGE(DGPH1,DGPH2,DGPH3,DGPHDFN) ;Check to see if the entry has changed
+1 ; Input:
+2 ; DGPH1 - PH Indicator
+3 ; DGPH2 - PH Status
+4 ; DGPH3 - PH Remarks
+5 ; DGPHDFN- Patient file IEN
+6 ;
+7 ; Output: none
+8 ;
+9 ; Return: DGCHG = 1 - Change in any of the input values has occurred
+10 ; DGCHG = 0 - No change
+11 ;
+12 ;Return value
NEW DGCHG
+13 ;Array containing last values from audit
NEW DGARR
+14 ;Merged array of DGARR
NEW DGPHVAL
+15 ;Error root for DIQ
NEW DGERR
+16 ;IEN of last audit value
NEW DGIEN
+17 ;Purple Heart Multiple
NEW DGFILE
+18 ;Index counter
NEW DGI
+19 ;
+20 KILL DGPHINC
+21 SET DGCHG=0
+22 SET DGFILE=2.0534
+23 SET DGIEN=$ORDER(^DPT(DGPHDFN,"PH","B"),-1)
+24 IF DGIEN=""
SET DGCHG=1
GOTO AUDITQ
+25 DO GETS^DIQ(DGFILE,DGIEN_","_DGPHDFN_",","1;2;3","I","DGARR","DGERR")
+26 IF $DATA(DGERR)
SET DGCHG=1
GOTO AUDITQ
+27 MERGE DGPHVAL=DGARR(DGFILE,DGIEN_","_DGPHDFN_",")
+28 FOR DGI=1:1:3
IF @("DGPH"_DGI)'=DGPHVAL(DGI,"I")
Begin DoDot:1
+29 SET DGCHG=1
+30 ; PH INDICATOR has changed
IF DGI=1
Begin DoDot:2
+31 ; Package Variable to note PH Indicator has changed
IF DGPH1="N"
IF DGPHVAL(DGI,"I")="Y"
SET DGPHINC=1
End DoDot:2
End DoDot:1
AUDITQ QUIT DGCHG
