VAFHPST1 ;ALB/JRP,PKE - POST INIT ROUTINE;07-JUN-1996
;;5.3;Registration;**91**;AUG 13, 1993
;
FACILITY ;set facility name in HL7 APPLICATIONS #771
;
;input : None
;ouput : None
D BMES^XPDUTL(">>> Adding Facility-Station number to 'VAFH PIMS' entry in File #771")
N DIC,DIE,DA,DR,C,D,DI,D0,DQ,%,X,Y,DTOUT,DUOUT
S X="VAFH PIMS",DIC(0)="MZ" S (DIE,DIC)="^HL(771,"
D ^DIC
I Y<1 DO QUIT
.D BMES^XPDUTL(">>> 'VAFH PIMS' entry NOT found in File #771")
.D BMES^XPDUTL("... ")
S DA=+Y,DR="3///^S X=+$$SITE^VASITE()"
D ^DIE
;
D BMES^XPDUTL(">>> Adding Facility-Station number to 'VAFC PIMS' entry in File #771")
N DIC,DIE,DA,DR,C,D,DI,D0,DQ,%,X,Y,DTOUT,DUOUT
S X="VAFC PIMS",DIC(0)="MZ" S (DIE,DIC)="^HL(771,"
D ^DIC
I Y<1 DO QUIT
.D BMES^XPDUTL(">>> 'VAFC PIMS' entry NOT found in File #771")
.D BMES^XPDUTL("... ")
S DA=+Y,DR="3///^S X=+$$SITE^VASITE()"
D ^DIE
Q
;
PARA ;this tag will set the pivot file number at install time. It will
;not write over an existing number.
N VAR,VAR1
S VAR1=$O(^DG(43,0))
I 'VAR1 DO Q
.D MES^XPDUTL("There does not seem to be an MAS PARAMETER file. Did not set Pivot Number.")
;
I +$G(^DG(43,VAR1,"HL7")) Q
S VAR=+$O(^DGPM("A"),-1)
I 'VAR DO Q
.D MES^XPDUTL("Could not obtain a number from the Patient Movement file. Pivot Number not updated.")
;
S VAR=VAR+1000
S $P(^DG(43,VAR1,"HL7"),U,1)=VAR
D MES^XPDUTL(".")
Q
;
;
DISABLE ;this tag will disable the protocol from the first development effort.
;just in case
K DIC,DIE,X,Y,DA,DR
S DIC="^ORD(101,",DIC(0)="MZ",X="A1BV PHILADELPHIA HL7 UPDATES"
D ^DIC
K DIC
I Y<0 S VAFHX=X DO
.;D BMES^XPDUTL("Could not find the protocol ",X," Nothing closed.")
I Y>0 DO
.S DIE="^ORD(101,",DIC(0)="MZ",DA=+Y,DR="2///Out of Order"
.D ^DIE
.D BMES^XPDUTL("A1BV PHILADELPHIA HL7 UPDATES now out of order!")
K DIC,DIE,X,Y,DA,DR
Q
;
COMPILE N GLOBAL,FIELD,CFIELD,NFIELD,TEMPLATP,TEMPLATN
;
D BMES^XPDUTL("Beginning to compile templates on the patient file.")
;
S NFIELD=$P($T(AFIELDS),";;",2) ;get the fields that have new xref
;
F GLOBAL="^DIE","^DIPT" DO
.I GLOBAL="^DIE" D BMES^XPDUTL(" Compiling Input Templates")
.I GLOBAL="^DIPT" DO
. . D BMES^XPDUTL(" ")
. . D BMES^XPDUTL(" Compiling Print Templates")
.;
.S FIELD=0
.; go find templates on fields on fields that have added cross-ref
.F S FIELD=$O(@GLOBAL@("AF",2,FIELD)) Q:'FIELD DO
. .;
. .S CFIELD=","_FIELD_","
. .;if we didn't add the cross reference, quit
. .I NFIELD'[CFIELD Q
. .;
. .S TEMPLATP=0
. .F S TEMPLATP=$O(@GLOBAL@("AF",2,FIELD,TEMPLATP)) Q:'TEMPLATP DO
. . . S TEMPLATN=$P($G(@GLOBAL@(TEMPLATP,0)),"^",1)
. . . I TEMPLATN="" DO Q
. . . . D BMES^XPDUTL("Could not compile template "_TEMPLATN_$C(13,10)_"Please review!")
. . . .;
. . . S X=$P($G(@GLOBAL@(TEMPLATP,"ROUOLD")),"^")
. . . I X="" DO Q
. . . . D BMES^XPDUTL("Could not find routine for template "_TEMPLATN_$C(13,10)_"Please review!")
. . . I $D(FIELD(X)) Q ;already compiled
. . .;
. . . S FIELD(X)="" ; remember the template was compiled
. . . S Y=TEMPLATP ; set up the call for fman
. . . S DMAX=$$ROUSIZE^DILF
. . . I GLOBAL="^DIE" D EN^DIEZ Q
. . . I GLOBAL="^DIPT" D EN^DIPZ Q
.;
W !!!
S (X,Y)=""
D BMES^XPDUTL("The following routine namespace was compiled:")
F S X=$O(FIELD(X)) Q:X="" DO
. S Y=$G(Y)+1 S PRINT(Y)=" "_X_"*"
;
D MES^XPDUTL(.PRINT)
Q
;
;these are the fields that have a new cross-ref
AFIELDS ;;,.01,.02,.03,.05,.06,.08,.09,.111,.1112,.112,.113,.114,.115,.117,.131,.132,.211,.219,.2403,.301,.302,.31115,.323,.351,.363,391,1901,
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVAFHPST1 3709 printed Nov 22, 2024@18:13:45 Page 2
VAFHPST1 ;ALB/JRP,PKE - POST INIT ROUTINE;07-JUN-1996
+1 ;;5.3;Registration;**91**;AUG 13, 1993
+2 ;
FACILITY ;set facility name in HL7 APPLICATIONS #771
+1 ;
+2 ;input : None
+3 ;ouput : None
+4 DO BMES^XPDUTL(">>> Adding Facility-Station number to 'VAFH PIMS' entry in File #771")
+5 NEW DIC,DIE,DA,DR,C,D,DI,D0,DQ,%,X,Y,DTOUT,DUOUT
+6 SET X="VAFH PIMS"
SET DIC(0)="MZ"
SET (DIE,DIC)="^HL(771,"
+7 DO ^DIC
+8 IF Y<1
Begin DoDot:1
+9 DO BMES^XPDUTL(">>> 'VAFH PIMS' entry NOT found in File #771")
+10 DO BMES^XPDUTL("... ")
End DoDot:1
QUIT
+11 SET DA=+Y
SET DR="3///^S X=+$$SITE^VASITE()"
+12 DO ^DIE
+13 ;
+14 DO BMES^XPDUTL(">>> Adding Facility-Station number to 'VAFC PIMS' entry in File #771")
+15 NEW DIC,DIE,DA,DR,C,D,DI,D0,DQ,%,X,Y,DTOUT,DUOUT
+16 SET X="VAFC PIMS"
SET DIC(0)="MZ"
SET (DIE,DIC)="^HL(771,"
+17 DO ^DIC
+18 IF Y<1
Begin DoDot:1
+19 DO BMES^XPDUTL(">>> 'VAFC PIMS' entry NOT found in File #771")
+20 DO BMES^XPDUTL("... ")
End DoDot:1
QUIT
+21 SET DA=+Y
SET DR="3///^S X=+$$SITE^VASITE()"
+22 DO ^DIE
+23 QUIT
+24 ;
PARA ;this tag will set the pivot file number at install time. It will
+1 ;not write over an existing number.
+2 NEW VAR,VAR1
+3 SET VAR1=$ORDER(^DG(43,0))
+4 IF 'VAR1
Begin DoDot:1
+5 DO MES^XPDUTL("There does not seem to be an MAS PARAMETER file. Did not set Pivot Number.")
End DoDot:1
QUIT
+6 ;
+7 IF +$GET(^DG(43,VAR1,"HL7"))
QUIT
+8 SET VAR=+$ORDER(^DGPM("A"),-1)
+9 IF 'VAR
Begin DoDot:1
+10 DO MES^XPDUTL("Could not obtain a number from the Patient Movement file. Pivot Number not updated.")
End DoDot:1
QUIT
+11 ;
+12 SET VAR=VAR+1000
+13 SET $PIECE(^DG(43,VAR1,"HL7"),U,1)=VAR
+14 DO MES^XPDUTL(".")
+15 QUIT
+16 ;
+17 ;
DISABLE ;this tag will disable the protocol from the first development effort.
+1 ;just in case
+2 KILL DIC,DIE,X,Y,DA,DR
+3 SET DIC="^ORD(101,"
SET DIC(0)="MZ"
SET X="A1BV PHILADELPHIA HL7 UPDATES"
+4 DO ^DIC
+5 KILL DIC
+6 IF Y<0
SET VAFHX=X
Begin DoDot:1
+7 ;D BMES^XPDUTL("Could not find the protocol ",X," Nothing closed.")
End DoDot:1
+8 IF Y>0
Begin DoDot:1
+9 SET DIE="^ORD(101,"
SET DIC(0)="MZ"
SET DA=+Y
SET DR="2///Out of Order"
+10 DO ^DIE
+11 DO BMES^XPDUTL("A1BV PHILADELPHIA HL7 UPDATES now out of order!")
End DoDot:1
+12 KILL DIC,DIE,X,Y,DA,DR
+13 QUIT
+14 ;
COMPILE NEW GLOBAL,FIELD,CFIELD,NFIELD,TEMPLATP,TEMPLATN
+1 ;
+2 DO BMES^XPDUTL("Beginning to compile templates on the patient file.")
+3 ;
+4 ;get the fields that have new xref
SET NFIELD=$PIECE($TEXT(AFIELDS),";;",2)
+5 ;
+6 FOR GLOBAL="^DIE","^DIPT"
Begin DoDot:1
+7 IF GLOBAL="^DIE"
DO BMES^XPDUTL(" Compiling Input Templates")
+8 IF GLOBAL="^DIPT"
Begin DoDot:2
+9 DO BMES^XPDUTL(" ")
+10 DO BMES^XPDUTL(" Compiling Print Templates")
End DoDot:2
+11 ;
+12 SET FIELD=0
+13 ; go find templates on fields on fields that have added cross-ref
+14 FOR
SET FIELD=$ORDER(@GLOBAL@("AF",2,FIELD))
if 'FIELD
QUIT
Begin DoDot:2
+15 ;
+16 SET CFIELD=","_FIELD_","
+17 ;if we didn't add the cross reference, quit
+18 IF NFIELD'[CFIELD
QUIT
+19 ;
+20 SET TEMPLATP=0
+21 FOR
SET TEMPLATP=$ORDER(@GLOBAL@("AF",2,FIELD,TEMPLATP))
if 'TEMPLATP
QUIT
Begin DoDot:3
+22 SET TEMPLATN=$PIECE($GET(@GLOBAL@(TEMPLATP,0)),"^",1)
+23 IF TEMPLATN=""
Begin DoDot:4
+24 DO BMES^XPDUTL("Could not compile template "_TEMPLATN_$CHAR(13,10)_"Please review!")
+25 ;
End DoDot:4
QUIT
+26 SET X=$PIECE($GET(@GLOBAL@(TEMPLATP,"ROUOLD")),"^")
+27 IF X=""
Begin DoDot:4
+28 DO BMES^XPDUTL("Could not find routine for template "_TEMPLATN_$CHAR(13,10)_"Please review!")
End DoDot:4
QUIT
+29 ;already compiled
IF $DATA(FIELD(X))
QUIT
+30 ;
+31 ; remember the template was compiled
SET FIELD(X)=""
+32 ; set up the call for fman
SET Y=TEMPLATP
+33 SET DMAX=$$ROUSIZE^DILF
+34 IF GLOBAL="^DIE"
DO EN^DIEZ
QUIT
+35 IF GLOBAL="^DIPT"
DO EN^DIPZ
QUIT
End DoDot:3
End DoDot:2
+36 ;
End DoDot:1
+37 WRITE !!!
+38 SET (X,Y)=""
+39 DO BMES^XPDUTL("The following routine namespace was compiled:")
+40 FOR
SET X=$ORDER(FIELD(X))
if X=""
QUIT
Begin DoDot:1
+41 SET Y=$GET(Y)+1
SET PRINT(Y)=" "_X_"*"
End DoDot:1
+42 ;
+43 DO MES^XPDUTL(.PRINT)
+44 QUIT
+45 ;
+46 ;these are the fields that have a new cross-ref
AFIELDS ;;,.01,.02,.03,.05,.06,.08,.09,.111,.1112,.112,.113,.114,.115,.117,.131,.132,.211,.219,.2403,.301,.302,.31115,.323,.351,.363,391,1901,
+1 QUIT
