VAQLED07 ;ALB/JFP,JRP - DISPLAY MINIMAL DATA/ADD NEW PATIENT ;01MAR93 [ 12/04/96 9:23 AM ]
;;1.5;PATIENT DATA EXCHANGE;**13,22,23,43**;NOV 17, 1993
EP ; -- Main entry point for the list processor
; Note: sets flag 'VAQADFL' if required elements are blank
;
K ^TMP("VAQD1",$J),^TMP("VAQDIS",$J)
S (VAQADFL,VALMCNT)=0
;
EXTR ; -- Extract PDX minimal data
S DFN=DFNTR
S ROOT="^TMP(""VAQDIS"",$J)"
S SEGPTR=$O(^VAT(394.71,"C","PDX*MIN",""))
S VAQIGNC=1 ; -- turns of encryption
S X=$$SEGEXT^VAQUPD1(DFN,SEGPTR,ROOT)
I +X=-1 W !,"Extract not successful...Error: "_$P(X,U,2) D PAUSE^VALM1 QUIT
; -- extraction sucessful,check for missing data
D CHKNULL
I VAQADFL=1 D Q
.S VAQST="** Unable to load patient...required elements missing"
.D EN^VALM("VAQ DIS MIN NUPD") ; -- Protocol = VAQ DIS1 (MENU)
S VAQST="** <AP> attempt to add new patient or <RETURN> to exit"
D EN^VALM("VAQ DIS MIN UPD") ; -- protocol = VAQ PDX7 (MENU)
QUIT
;
INIT ; -- Builds array of minimal data for the patient entered (DFN)
S XTRCT=ROOT
S ROOT="^TMP(""VAQD1"",$J)"
S (OFFSET,DSP)=0
S X=$$DISPMIN^VAQDIS21(XTRCT,SEGPTR,ROOT,OFFSET,DSP)
I +X=-1 S MSG="Display load not successful...Error: "_$P(X,U,2) D ERRMSG QUIT
S VALMCNT=+X-1
D DISMSG
K VALMBCK
QUIT
;
HD ; -- Make header line for list processor
D HD1^VAQEXT02 QUIT
;
ADD ; -- Adds new patient to local data base
D CLEAR^VALM1
W !,"Please wait while information on ",$G(^TMP("VAQDIS",$J,"VALUE",2,.01,0))," is added",!
I $G(^TMP("VAQDIS",$J,"VALUE",2,.09,0))'["P",$O(^DPT("SSN",$G(^TMP("VAQDIS",$J,"VALUE",2,.09,0)),"")) D Q
. W !!,$C(7),"** Patient not added, SSN in use by existing patient"
. W !
. D TRANEX
S DIC="^DPT("
S DIC(0)="EL"
S DLAYGO=2
S X=$G(^TMP("VAQDIS",$J,"VALUE",2,.01,0))
S DIC("DR")=".03///"_$G(^TMP("VAQDIS",$J,"VALUE",2,.03,0))
F I=.09,391,1901 S DIC("DR")=DIC("DR")_";"_I_"///"_$G(^TMP("VAQDIS",$J,"VALUE",2,I,0))
K DD,D0 D FILE^DICN K DIC,DLAYGO
I $P(Y,U,3)'=1 W !!,$C(7),"** Patient not added",! D TRANEX QUIT
;
; -- Update workload file (new patient)
D WORKLD
; -- Add rest of information for stub"
S VAQSTUB=+Y
S LOCKFLE=$G(^DIC(2,0,"GL"))
L +(@(LOCKFLE_VAQSTUB_")")):60
I ('$T) W !,"Could not edit entry...record locked" K LOCKFLE QUIT
F FLD=.02,.05,.08,.301,.302,.361,.323,.111,.112,.113,.114,.115,.1112,.117 D LOAD
; -- load temporary address information, if active
D TMPADDR QUIT
L -(@(LOCKFLE_VAQSTUB_")")) K LOCKFLE
W !,"** PDX minimal information on ",$G(^TMP("VAQDIS",$J,"VALUE",2,.01,0))," has been added"
D TRANEX
D EP^VAQLED02
K VALMBCK
QUIT
;
LOAD ; -- Loads fields to patient file
S DIE=2,(DA,DFNPT)=VAQSTUB
S DR=FLD_"///^S X=$G(^TMP(""VAQDIS"",$J,""VALUE"",2,FLD,0))"
D ^DIE K DIE,DA,DR
I ($D(Y)#2) W ?10,"- ",$P(^DD(2,FLD,0),U,1),?40," could not be added",!
QUIT
;
TMPADDR ; -- Checks to see if temporary address dates are active and flag set
; -- active flag
I $G(^TMP("VAQDIS",$J,"VALUE",2,.12105,0))="Y" QUIT ;strt dte
I $G(^TMP("VAQDIS",$J,"VALUE",2,.1217,0))'<DT QUIT ;strt dte
I $G(^TMP("VAQDIS",$J,"VALUE",2,.1218,0))'>DT QUIT ;end dte
; -- Load temporary address fields
F FLD=.12105,.1211,.12111,.12112,.1212,.1213,.1214,.1215,.12112,.1217,.1218,.1219 D LOAD
QUIT
;
ERRMSG ; -- Displays error message
S X=$$SETSTR^VALM1(" ","",1,79) D TMP
S X=$$SETSTR^VALM1(MSG,"",1,80) D TMP
S VALMBCK="Q"
QUIT
;
DISMSG ; -- Display status message
S X=$$SETSTR^VALM1(VAQST,"",1,79) D TMP
K VAQLN,VAQST
QUIT
;
TMP ; -- Set the array used by list processor
S VALMCNT=VALMCNT+1
S ^TMP("VAQD1",$J,VALMCNT,0)=$E(X,1,79)
QUIT
;
CHKNULL ; -- Sets missing data flag if it finds a required field null
; Added quit condition. NOIS ISD-0495-40199
S FLD=""
F FLD=.01,.02,.03,.05,.08,.09,.111,.114,.115,.1112,.117,.323,.361,391,1901 Q:(VAQADFL=1) D
.S VAQDATA=$G(^TMP("VAQDIS",$J,"VALUE",2,FLD,0))
.S:VAQDATA="" VAQADFL=1
I VAQADFL=0 D
.S:($G(^TMP("VAQDIS",$J,"VALUE",2,.302,0))=""&($G(^TMP("VAQDIS",$J,"VALUE",2,.301,0))'="NO")) VAQADFL=0
K FLD,VAQDATA
QUIT
;
TRANEX ; -- Transaction exit
D PAUSE^VALM1
S VALMBCK="Q"
QUIT
;
WORKLD ; -- Updates work load file
S X=$$WORKDONE^VAQADS01("NEW",DFNTR,$G(DUZ))
I +X<0 W !,"Error updating work loadfile (NEW)... "_$P(X,U,2)
I $P($G(^VAT(394.61,DFNTR,0)),U,4)=0 QUIT
S X=$$WORKDONE^VAQADS01("SNSTVE",DFNTR,$G(DUZ))
I X<0 W !,"Error updating workload file (SNSTVE)... "_$P(X,U,2)
QUIT
;
EXIT ; -- Note: The list processor cleans up its own variables.
; All other variables cleaned up here.
;
K ^TMP("VAQD1",$J),^TMP("VAQDIS",$J)
K VAQADFL,VAQSTUB,VAQIGNC
K VALMCNT,ROOT,SEGPTR,X,MSG,XTRCT,OFFSET,DSP
Q
;
END ; -- End of code
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVAQLED07 4794 printed Sep 23, 2025@20:01:42 Page 2
VAQLED07 ;ALB/JFP,JRP - DISPLAY MINIMAL DATA/ADD NEW PATIENT ;01MAR93 [ 12/04/96 9:23 AM ]
+1 ;;1.5;PATIENT DATA EXCHANGE;**13,22,23,43**;NOV 17, 1993
EP ; -- Main entry point for the list processor
+1 ; Note: sets flag 'VAQADFL' if required elements are blank
+2 ;
+3 KILL ^TMP("VAQD1",$JOB),^TMP("VAQDIS",$JOB)
+4 SET (VAQADFL,VALMCNT)=0
+5 ;
EXTR ; -- Extract PDX minimal data
+1 SET DFN=DFNTR
+2 SET ROOT="^TMP(""VAQDIS"",$J)"
+3 SET SEGPTR=$ORDER(^VAT(394.71,"C","PDX*MIN",""))
+4 ; -- turns of encryption
SET VAQIGNC=1
+5 SET X=$$SEGEXT^VAQUPD1(DFN,SEGPTR,ROOT)
+6 IF +X=-1
WRITE !,"Extract not successful...Error: "_$PIECE(X,U,2)
DO PAUSE^VALM1
QUIT
+7 ; -- extraction sucessful,check for missing data
+8 DO CHKNULL
+9 IF VAQADFL=1
Begin DoDot:1
+10 SET VAQST="** Unable to load patient...required elements missing"
+11 ; -- Protocol = VAQ DIS1 (MENU)
DO EN^VALM("VAQ DIS MIN NUPD")
End DoDot:1
QUIT
+12 SET VAQST="** <AP> attempt to add new patient or <RETURN> to exit"
+13 ; -- protocol = VAQ PDX7 (MENU)
DO EN^VALM("VAQ DIS MIN UPD")
+14 QUIT
+15 ;
INIT ; -- Builds array of minimal data for the patient entered (DFN)
+1 SET XTRCT=ROOT
+2 SET ROOT="^TMP(""VAQD1"",$J)"
+3 SET (OFFSET,DSP)=0
+4 SET X=$$DISPMIN^VAQDIS21(XTRCT,SEGPTR,ROOT,OFFSET,DSP)
+5 IF +X=-1
SET MSG="Display load not successful...Error: "_$PIECE(X,U,2)
DO ERRMSG
QUIT
+6 SET VALMCNT=+X-1
+7 DO DISMSG
+8 KILL VALMBCK
+9 QUIT
+10 ;
HD ; -- Make header line for list processor
+1 DO HD1^VAQEXT02
QUIT
+2 ;
ADD ; -- Adds new patient to local data base
+1 DO CLEAR^VALM1
+2 WRITE !,"Please wait while information on ",$GET(^TMP("VAQDIS",$JOB,"VALUE",2,.01,0))," is added",!
+3 IF $GET(^TMP("VAQDIS",$JOB,"VALUE",2,.09,0))'["P"
IF $ORDER(^DPT("SSN",$GET(^TMP("VAQDIS",$JOB,"VALUE",2,.09,0)),""))
Begin DoDot:1
+4 WRITE !!,$CHAR(7),"** Patient not added, SSN in use by existing patient"
+5 WRITE !
+6 DO TRANEX
End DoDot:1
QUIT
+7 SET DIC="^DPT("
+8 SET DIC(0)="EL"
+9 SET DLAYGO=2
+10 SET X=$GET(^TMP("VAQDIS",$JOB,"VALUE",2,.01,0))
+11 SET DIC("DR")=".03///"_$GET(^TMP("VAQDIS",$JOB,"VALUE",2,.03,0))
+12 FOR I=.09,391,1901
SET DIC("DR")=DIC("DR")_";"_I_"///"_$GET(^TMP("VAQDIS",$JOB,"VALUE",2,I,0))
+13 KILL DD,D0
DO FILE^DICN
KILL DIC,DLAYGO
+14 IF $PIECE(Y,U,3)'=1
WRITE !!,$CHAR(7),"** Patient not added",!
DO TRANEX
QUIT
+15 ;
+16 ; -- Update workload file (new patient)
+17 DO WORKLD
+18 ; -- Add rest of information for stub"
+19 SET VAQSTUB=+Y
+20 SET LOCKFLE=$GET(^DIC(2,0,"GL"))
+21 LOCK +(@(LOCKFLE_VAQSTUB_")")):60
+22 IF ('$TEST)
WRITE !,"Could not edit entry...record locked"
KILL LOCKFLE
QUIT
+23 FOR FLD=.02,.05,.08,.301,.302,.361,.323,.111,.112,.113,.114,.115,.1112,.117
DO LOAD
+24 ; -- load temporary address information, if active
+25 DO TMPADDR
QUIT
+26 LOCK -(@(LOCKFLE_VAQSTUB_")"))
KILL LOCKFLE
+27 WRITE !,"** PDX minimal information on ",$GET(^TMP("VAQDIS",$JOB,"VALUE",2,.01,0))," has been added"
+28 DO TRANEX
+29 DO EP^VAQLED02
+30 KILL VALMBCK
+31 QUIT
+32 ;
LOAD ; -- Loads fields to patient file
+1 SET DIE=2
SET (DA,DFNPT)=VAQSTUB
+2 SET DR=FLD_"///^S X=$G(^TMP(""VAQDIS"",$J,""VALUE"",2,FLD,0))"
+3 DO ^DIE
KILL DIE,DA,DR
+4 IF ($DATA(Y)#2)
WRITE ?10,"- ",$PIECE(^DD(2,FLD,0),U,1),?40," could not be added",!
+5 QUIT
+6 ;
TMPADDR ; -- Checks to see if temporary address dates are active and flag set
+1 ; -- active flag
+2 ;strt dte
IF $GET(^TMP("VAQDIS",$JOB,"VALUE",2,.12105,0))="Y"
QUIT
+3 ;strt dte
IF $GET(^TMP("VAQDIS",$JOB,"VALUE",2,.1217,0))'<DT
QUIT
+4 ;end dte
IF $GET(^TMP("VAQDIS",$JOB,"VALUE",2,.1218,0))'>DT
QUIT
+5 ; -- Load temporary address fields
+6 FOR FLD=.12105,.1211,.12111,.12112,.1212,.1213,.1214,.1215,.12112,.1217,.1218,.1219
DO LOAD
+7 QUIT
+8 ;
ERRMSG ; -- Displays error message
+1 SET X=$$SETSTR^VALM1(" ","",1,79)
DO TMP
+2 SET X=$$SETSTR^VALM1(MSG,"",1,80)
DO TMP
+3 SET VALMBCK="Q"
+4 QUIT
+5 ;
DISMSG ; -- Display status message
+1 SET X=$$SETSTR^VALM1(VAQST,"",1,79)
DO TMP
+2 KILL VAQLN,VAQST
+3 QUIT
+4 ;
TMP ; -- Set the array used by list processor
+1 SET VALMCNT=VALMCNT+1
+2 SET ^TMP("VAQD1",$JOB,VALMCNT,0)=$EXTRACT(X,1,79)
+3 QUIT
+4 ;
CHKNULL ; -- Sets missing data flag if it finds a required field null
+1 ; Added quit condition. NOIS ISD-0495-40199
+2 SET FLD=""
+3 FOR FLD=.01,.02,.03,.05,.08,.09,.111,.114,.115,.1112,.117,.323,.361,391,1901
if (VAQADFL=1)
QUIT
Begin DoDot:1
+4 SET VAQDATA=$GET(^TMP("VAQDIS",$JOB,"VALUE",2,FLD,0))
+5 if VAQDATA=""
SET VAQADFL=1
End DoDot:1
+6 IF VAQADFL=0
Begin DoDot:1
+7 if ($GET(^TMP("VAQDIS",$JOB,"VALUE",2,.302,0))=""&($GET(^TMP("VAQDIS",$JOB,"VALUE",2,.301,0))'="NO"))
SET VAQADFL=0
End DoDot:1
+8 KILL FLD,VAQDATA
+9 QUIT
+10 ;
TRANEX ; -- Transaction exit
+1 DO PAUSE^VALM1
+2 SET VALMBCK="Q"
+3 QUIT
+4 ;
WORKLD ; -- Updates work load file
+1 SET X=$$WORKDONE^VAQADS01("NEW",DFNTR,$GET(DUZ))
+2 IF +X<0
WRITE !,"Error updating work loadfile (NEW)... "_$PIECE(X,U,2)
+3 IF $PIECE($GET(^VAT(394.61,DFNTR,0)),U,4)=0
QUIT
+4 SET X=$$WORKDONE^VAQADS01("SNSTVE",DFNTR,$GET(DUZ))
+5 IF X<0
WRITE !,"Error updating workload file (SNSTVE)... "_$PIECE(X,U,2)
+6 QUIT
+7 ;
EXIT ; -- Note: The list processor cleans up its own variables.
+1 ; All other variables cleaned up here.
+2 ;
+3 KILL ^TMP("VAQD1",$JOB),^TMP("VAQDIS",$JOB)
+4 KILL VAQADFL,VAQSTUB,VAQIGNC
+5 KILL VALMCNT,ROOT,SEGPTR,X,MSG,XTRCT,OFFSET,DSP
+6 QUIT
+7 ;
END ; -- End of code
+1 QUIT
