VAQPST02 ;ALB/JFP - PDX, POST INIT ROUTINE ;01JUN93
;;1.5;PATIENT DATA EXCHANGE;;NOV 17, 1993
PARM ; -- Initialization of VAQ Parameter file 394.81
N CNT,FILENO,FILE,ENTRY
W !!,"Initialization of VAQ - Parameter file",!
I '$D(^VAT(394.81)) W !,"Error...VAQ - Parameter file missing, post init halted" S POP=1 QUIT
P1 S FILENO=394.81,FILE="^VAT(394.81,"
S ENTRY=0,ENTRY=$O(^VAT(394.81,ENTRY))
I ENTRY="" D P2 QUIT
I $D(^VAT(394.81,ENTRY)) D MISSING^VAQPST01,PROMPT^VAQPST01,PEXIT QUIT
P2 S ENTRY=+$O(^VAT(394.2,0))
I ENTRY>0 D COPV1 Q:CNT=0 D P1 QUIT
; -- Add entry
S DIC="^VAT(394.81,"
S DIC(0)="L"
S DIC("DR")=".02;10;20;21;30;31"
S X=+$$SITE^VASITE()
S DLAYGO=394.81
K DD,DO
D FILE^DICN K DIC,DLAYGO,X
I Y<0 W !,"Error...Could not make an entry on VAQ - Parameter file" S POP=1 QUIT
W !!," ** Initialization of VAQ - Parameter file complete"
D PEXIT
QUIT
;
COPV1 ; -- Copy version 1 fields to version 1.5
S CNT=0
S ND=$G(^VAT(394.2,ENTRY,0))
S FAC=$P(ND,U,5) I FAC="" S CNT=CNT+1 QUIT
S LFDATA=$P(ND,U,3) I LFDATA="" S CNT=CNT+1
S DOM=$P(ND,U,4) I DOM="" S CNT=CNT+1
S DIC="^VAT(394.81,"
S DIC(0)="L"
;S DIC("DR")=".02////"_DOM_";10///"_LFDATA_";20///NO;21///Kernal-Hasing"
S DIC("DR")=".02////"_DOM_";10///"_LFDATA_";20///NO;21///Kernel Hashing"
S X=FAC
S DLAYGO=394.81
K DD,DO
D FILE^DICN K DIC,DLAYGO,X
I Y<0 W !,"Error...Could not make an entry on VAQ - Parameter file" S POP=1 QUIT
W !!," ** Initialization of VAQ - Parameter file complete"
D PEXIT
QUIT
;
PEXIT ; -- Clean up variables
K FILNO,FILE,ENTRY
K ND,FAC,DOM,LFDATA
QUIT
;
AUTO ; -- Initialization of VAQ - Auto-numbering file 394.86
W !!,"Initialization of VAQ - Auto-numbering file",!
I '$D(^VAT(394.86)) W !,"Error...VAQ - Auto-numbering file missing, post init halted" S POP=1 QUIT
S FILENO=394.86,FILE="^VAT(394.86,"
S ENTRY=0 S ENTRY=$O(^VAT(394.86,ENTRY))
I ENTRY="" D A1 QUIT
I $D(^VAT(394.86,ENTRY)) D MISSING^VAQPST01,PROMPT^VAQPST01 QUIT
A1 ; -- Add entry
S DIC="^VAT(394.86,"
S DIC(0)="L"
S DIC("DR")="10///100;20///0;30///0"
S X=1
S DINUM=1
S DLAYGO=394.86
K DD,DO
D FILE^DICN K DIC,DLAYGO,DINUM,X
I Y<0 W !,"Error...Could not make an entry on VAQ - Auto-numbering file" S POP=1 QUIT
W !!," ** Initialization of VAQ - Auto-numbering file complete"
K FILENO,FILE,ENTRY
QUIT
END ; -- End of code
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVAQPST02 2412 printed Apr 09, 2024@21:27:59 Page 2
VAQPST02 ;ALB/JFP - PDX, POST INIT ROUTINE ;01JUN93
+1 ;;1.5;PATIENT DATA EXCHANGE;;NOV 17, 1993
PARM ; -- Initialization of VAQ Parameter file 394.81
+1 NEW CNT,FILENO,FILE,ENTRY
+2 WRITE !!,"Initialization of VAQ - Parameter file",!
+3 IF '$DATA(^VAT(394.81))
WRITE !,"Error...VAQ - Parameter file missing, post init halted"
SET POP=1
QUIT
P1 SET FILENO=394.81
SET FILE="^VAT(394.81,"
+1 SET ENTRY=0
SET ENTRY=$ORDER(^VAT(394.81,ENTRY))
+2 IF ENTRY=""
DO P2
QUIT
+3 IF $DATA(^VAT(394.81,ENTRY))
DO MISSING^VAQPST01
DO PROMPT^VAQPST01
DO PEXIT
QUIT
P2 SET ENTRY=+$ORDER(^VAT(394.2,0))
+1 IF ENTRY>0
DO COPV1
if CNT=0
QUIT
DO P1
QUIT
+2 ; -- Add entry
+3 SET DIC="^VAT(394.81,"
+4 SET DIC(0)="L"
+5 SET DIC("DR")=".02;10;20;21;30;31"
+6 SET X=+$$SITE^VASITE()
+7 SET DLAYGO=394.81
+8 KILL DD,DO
+9 DO FILE^DICN
KILL DIC,DLAYGO,X
+10 IF Y<0
WRITE !,"Error...Could not make an entry on VAQ - Parameter file"
SET POP=1
QUIT
+11 WRITE !!," ** Initialization of VAQ - Parameter file complete"
+12 DO PEXIT
+13 QUIT
+14 ;
COPV1 ; -- Copy version 1 fields to version 1.5
+1 SET CNT=0
+2 SET ND=$GET(^VAT(394.2,ENTRY,0))
+3 SET FAC=$PIECE(ND,U,5)
IF FAC=""
SET CNT=CNT+1
QUIT
+4 SET LFDATA=$PIECE(ND,U,3)
IF LFDATA=""
SET CNT=CNT+1
+5 SET DOM=$PIECE(ND,U,4)
IF DOM=""
SET CNT=CNT+1
+6 SET DIC="^VAT(394.81,"
+7 SET DIC(0)="L"
+8 ;S DIC("DR")=".02////"_DOM_";10///"_LFDATA_";20///NO;21///Kernal-Hasing"
+9 SET DIC("DR")=".02////"_DOM_";10///"_LFDATA_";20///NO;21///Kernel Hashing"
+10 SET X=FAC
+11 SET DLAYGO=394.81
+12 KILL DD,DO
+13 DO FILE^DICN
KILL DIC,DLAYGO,X
+14 IF Y<0
WRITE !,"Error...Could not make an entry on VAQ - Parameter file"
SET POP=1
QUIT
+15 WRITE !!," ** Initialization of VAQ - Parameter file complete"
+16 DO PEXIT
+17 QUIT
+18 ;
PEXIT ; -- Clean up variables
+1 KILL FILNO,FILE,ENTRY
+2 KILL ND,FAC,DOM,LFDATA
+3 QUIT
+4 ;
AUTO ; -- Initialization of VAQ - Auto-numbering file 394.86
+1 WRITE !!,"Initialization of VAQ - Auto-numbering file",!
+2 IF '$DATA(^VAT(394.86))
WRITE !,"Error...VAQ - Auto-numbering file missing, post init halted"
SET POP=1
QUIT
+3 SET FILENO=394.86
SET FILE="^VAT(394.86,"
+4 SET ENTRY=0
SET ENTRY=$ORDER(^VAT(394.86,ENTRY))
+5 IF ENTRY=""
DO A1
QUIT
+6 IF $DATA(^VAT(394.86,ENTRY))
DO MISSING^VAQPST01
DO PROMPT^VAQPST01
QUIT
A1 ; -- Add entry
+1 SET DIC="^VAT(394.86,"
+2 SET DIC(0)="L"
+3 SET DIC("DR")="10///100;20///0;30///0"
+4 SET X=1
+5 SET DINUM=1
+6 SET DLAYGO=394.86
+7 KILL DD,DO
+8 DO FILE^DICN
KILL DIC,DLAYGO,DINUM,X
+9 IF Y<0
WRITE !,"Error...Could not make an entry on VAQ - Auto-numbering file"
SET POP=1
QUIT
+10 WRITE !!," ** Initialization of VAQ - Auto-numbering file complete"
+11 KILL FILENO,FILE,ENTRY
+12 QUIT
END ; -- End of code
+1 QUIT
