SDECALV ;ALB/SAT - VISTA SCHEDULING RPCS ;JAN 15, 2016
;;5.3;Scheduling;**627**;Aug 13, 1993;Build 249
;
EN1(SDALVR) ;
EN ;VISIT CREATION
;required:
; SDDATE
; SDLOC
; SDPAT
;optional:
; SDALV (used in SDECALV1)
; SDALVR (used in SDECALV1)
; SDAPDT
; SDCODT
; SDHL - HOSPITAL LOCATION id
; SDLOC
; SDOPT
; SDPROT
; SDPVL
; SDTYPE
; SDUSR
; SDVELG
N D0,DA,DIC,DIE,DR
N SDAFLG,SDCAT,SDCLN,SDVSIT
N SDAPDT,SDCAT,SDCODT,SDDATE,SDHL,SDLOC,SDOLOC,SDOPT,SDPAT,SDPROT,SDPVL
N SDTYPE,SDUSR,SDVELG
D INIT^SDECALV1(.SDALVR)
S SDAPDT=$G(SDALVR("APPT DATE"))
S SDCAT=$G(SDALVR("SDCAT"))
S SDDATE=$G(SDALVR("SDDATE"))
S SDHL=$G(SDALVR("SDHL"))
S SDLOC=$G(SDALVR("SDLOC"))
S SDCODT=$G(SDALVR("SDCODT"))
S SDOLOC=$G(SDALVR("SDOLOC"))
S SDOPT=$G(SDALVR("SDOPT"))
S SDPAT=$G(SDALVR("SDPAT"))
S SDPROT=$G(SDALVR("SDPROT"))
S SDPVL=$G(SDALVR("SDPVL"))
S SDTYPE=$G(SDALVR("SDTYPE"))
S SDUSR=$G(SDALVR("SDUSR"))
S SDVELG=$G(SDALVR("SDVELG"))
I $D(SDAFLG) D EOJ Q
LOCK +^TMP("SDECALV",SDPAT):60
I $D(SDADD) D GENVISIT,EOJ Q ; forced add
Q
;
AUTO ; NON-INTERACTIVE MODE
S SDAVDC=9999999-$P(SDDATE,".")_"."_$P(SDDATE,".",2)
F SDAI=0:0 S SDAI=$O(^AUPNVSIT("AA",SDPAT,SDAVDC,SDAI)) Q:SDAI="" D CHECK Q:SDVSIT
Q:SDVSIT
D GENVISIT
Q
;
CHECK ; CHECK VISIT AUTO MODE
N SDAX
S SDAX=^AUPNVSIT(SDAI,0)
Q:$P(SDAX,U,11)
I $D(SDCLN),$P(SDAX,U,8)'=SDCLN Q ;CHANGED THIS LINE ON 4/4/96 - DOES THIS FIX IT?
I '$D(SDCLN),$P(SDAX,U,8)]"" Q ;if not passing clinic and visit has clinic do not select this visit
Q:$P(SDAX,U,3)'=SDTYPE
Q:$P(SDAX,U,6)'=SDLOC
Q:$P(SDAX,U,7)'=SDCAT
S SDVSIT=SDAI
Q
;
;--------------------------------------------------------------
;
GENVISIT ; GENERATE NEW VISIT
;INPUT:
; SDALVR("SDDATE") .01 VISIT/ADMIT DATE&TIME in fm format
; .02 DATE VISIT CREATED
; SDALVR("SDTYPE") .03 TYPE valid values:
; I:IHS
; C:CONTRACT
; T:TRIBAL
; O:OTHER
; 6:638 PROGRAM
; V:VA
; SDPAT .05 Patient pointer to PATIENT file 2
; SDLOC .06 LOC. OF ENCOUNTER pointer to LOCATION file
; SDCAT .07 Service Category
; SDCLN .08 DSS ID (Clinic Stop)
; SDPVL .12 Parent Visit Link
; .13 Date Last Modified in fm format
; SDCODT .18 Check out Date&Time
; SDVELG .21 Eligibility pointer to ELIGIBILITY CODE file 8
; SDHL .22 Hospital Location pointer to file 44
; SDUSR .23 Created by user pointer to NEW PERSON
; SDOPT .24 Option used to Create pointer to OPTION file
; SDPROT .25 Protocol pointer to PROTOCOL file
; SDOLOC 2101 outside location
;
N AUPNDOB,AUPNDOD,AUPNSEX
N SDDOB,SDDOD,SDFDA,SDIEN,SDMSG,SDSEX,X,Y,%DT
S Y=SDPAT D ^AUPNPAT K Y
S SDSEX=AUPNSEX,SDDOB=AUPNDOB,SDDOD=AUPNDOD
S X=$G(SDDATE),%DT="TRXN" D ^%DT S X=Y I X=-1 S SDAFLG=2,SDAFLG("ERR")=".01^"_SDDATE_"^DATE INVALID FOR PATIENT,CANNOT CREATE VISIT .01 VALUE" Q
D VSIT01^AUPNVSIT
I '$D(X) S SDAFLG=2,SDAFLG("ERR")=".01^"_SDDATE_"^DATE INVALID FOR PATIENT,CANNOT CREATE VISIT .01 VALUE" Q
S SDFDA="SDFDA(9000010,""+1,"")"
S @SDFDA@(.01)=SDDATE
S @SDFDA@(.02)=$$NOW^XLFDT
S @SDFDA@(.03)=$G(SDTYPE)
S @SDFDA@(.05)=$G(SDPAT)
S @SDFDA@(.06)=$G(SDLOC)
S @SDFDA@(.07)=$G(SDCAT)
S @SDFDA@(.08)=$G(SDCLN)
S @SDFDA@(.12)=$G(SDPVL)
S @SDFDA@(.13)=DT
S @SDFDA@(.18)=$G(SDCODT)
S @SDFDA@(.21)=$G(SDVELG)
S @SDFDA@(.22)=$G(SDHL)
S @SDFDA@(.23)=$G(SDUSR)
S @SDFDA@(.24)=$G(SDOPT)
S @SDFDA@(.25)=$G(SDPROT)
S @SDFDA@(2101)=$S($G(SDOLOC)]"":SDOLOC,1:"")
S VID=$$GETVID^VSITVID S @SDFDA@(15001)=VID
D UPDATE^DIE("","SDFDA","SDIEN","SDMSG")
;
I $D(SDMSG) S SDAFLG=2,SDAFLG("ERR")=".01^"_SDALVR("CDT")_"^VISIT CREATION FAILED" Q
S SDVSIT=+SDIEN(1)
I $T(GETVID^VSITVID)]"",$P($G(^DIC(150.9,1,4)),U,2)]"" S VID=$$GETVID^VSITVID S DIE=9000010,DA=SDVSIT,DR="15001///"_VID D ^DIE K VID,DIE,DR,DA
S SDVSIT("NEW")=1
Q
;
;--------------------------------------------------------------
;
INIT ; INITIALIZATION/EDIT INPUT VARIABLES
D INIT^SDECALV1
Q
;
EOJ ; CLEAN UP
LOCK -^TMP("SDECALV",SDPAT)
; The line below must 'hard set' the clinic code because
; ^DIE would have to be called recursively. An exception to the
; standard has been granted by DSM/OIRM.
I SDVSIT,$D(SDCLN),$P(^AUPNVSIT(SDVSIT,0),U,8)="" S $P(^AUPNVSIT(SDVSIT,0),U,8)=SDCLN ; ***** BAD, VERY BAD, FORGIVE US PLEASE *****
;I SDVSIT,$P($G(^AUPNVSIT(SDVSIT,11)),U,4)="" S $P(^AUPNVSIT(SDVSIT,11),U,4)=$$UID^AUPNVSIT(SDVSIT) ;stuff UID if blank
K X,Y
K DIRUT,DTOUT,DUOUT
K SDADD,SDADF
K SDAC,SDAI,SDAL,SDALV,SDAO,SDAVD,SDAVDC,SDAX,SDA11
I $D(SDALVR)\10 S SDALVR("SDPAT")=SDPAT,SDALVR("SDVSIT")=SDVSIT S:$D(SDVSIT("NEW")) SDALVR("SDVSIT","NEW")=SDVSIT("NEW") S:$D(SDAFLG) SDALVR("SDAFLG")=SDAFLG D EN1^SDECEKL
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDECALV 5044 printed Apr 09, 2024@21:47:31 Page 2
SDECALV ;ALB/SAT - VISTA SCHEDULING RPCS ;JAN 15, 2016
+1 ;;5.3;Scheduling;**627**;Aug 13, 1993;Build 249
+2 ;
EN1(SDALVR) ;
EN ;VISIT CREATION
+1 ;required:
+2 ; SDDATE
+3 ; SDLOC
+4 ; SDPAT
+5 ;optional:
+6 ; SDALV (used in SDECALV1)
+7 ; SDALVR (used in SDECALV1)
+8 ; SDAPDT
+9 ; SDCODT
+10 ; SDHL - HOSPITAL LOCATION id
+11 ; SDLOC
+12 ; SDOPT
+13 ; SDPROT
+14 ; SDPVL
+15 ; SDTYPE
+16 ; SDUSR
+17 ; SDVELG
+18 NEW D0,DA,DIC,DIE,DR
+19 NEW SDAFLG,SDCAT,SDCLN,SDVSIT
+20 NEW SDAPDT,SDCAT,SDCODT,SDDATE,SDHL,SDLOC,SDOLOC,SDOPT,SDPAT,SDPROT,SDPVL
+21 NEW SDTYPE,SDUSR,SDVELG
+22 DO INIT^SDECALV1(.SDALVR)
+23 SET SDAPDT=$GET(SDALVR("APPT DATE"))
+24 SET SDCAT=$GET(SDALVR("SDCAT"))
+25 SET SDDATE=$GET(SDALVR("SDDATE"))
+26 SET SDHL=$GET(SDALVR("SDHL"))
+27 SET SDLOC=$GET(SDALVR("SDLOC"))
+28 SET SDCODT=$GET(SDALVR("SDCODT"))
+29 SET SDOLOC=$GET(SDALVR("SDOLOC"))
+30 SET SDOPT=$GET(SDALVR("SDOPT"))
+31 SET SDPAT=$GET(SDALVR("SDPAT"))
+32 SET SDPROT=$GET(SDALVR("SDPROT"))
+33 SET SDPVL=$GET(SDALVR("SDPVL"))
+34 SET SDTYPE=$GET(SDALVR("SDTYPE"))
+35 SET SDUSR=$GET(SDALVR("SDUSR"))
+36 SET SDVELG=$GET(SDALVR("SDVELG"))
+37 IF $DATA(SDAFLG)
DO EOJ
QUIT
+38 LOCK +^TMP("SDECALV",SDPAT):60
+39 ; forced add
IF $DATA(SDADD)
DO GENVISIT
DO EOJ
QUIT
+40 QUIT
+41 ;
AUTO ; NON-INTERACTIVE MODE
+1 SET SDAVDC=9999999-$PIECE(SDDATE,".")_"."_$PIECE(SDDATE,".",2)
+2 FOR SDAI=0:0
SET SDAI=$ORDER(^AUPNVSIT("AA",SDPAT,SDAVDC,SDAI))
if SDAI=""
QUIT
DO CHECK
if SDVSIT
QUIT
+3 if SDVSIT
QUIT
+4 DO GENVISIT
+5 QUIT
+6 ;
CHECK ; CHECK VISIT AUTO MODE
+1 NEW SDAX
+2 SET SDAX=^AUPNVSIT(SDAI,0)
+3 if $PIECE(SDAX,U,11)
QUIT
+4 ;CHANGED THIS LINE ON 4/4/96 - DOES THIS FIX IT?
IF $DATA(SDCLN)
IF $PIECE(SDAX,U,8)'=SDCLN
QUIT
+5 ;if not passing clinic and visit has clinic do not select this visit
IF '$DATA(SDCLN)
IF $PIECE(SDAX,U,8)]""
QUIT
+6 if $PIECE(SDAX,U,3)'=SDTYPE
QUIT
+7 if $PIECE(SDAX,U,6)'=SDLOC
QUIT
+8 if $PIECE(SDAX,U,7)'=SDCAT
QUIT
+9 SET SDVSIT=SDAI
+10 QUIT
+11 ;
+12 ;--------------------------------------------------------------
+13 ;
GENVISIT ; GENERATE NEW VISIT
+1 ;INPUT:
+2 ; SDALVR("SDDATE") .01 VISIT/ADMIT DATE&TIME in fm format
+3 ; .02 DATE VISIT CREATED
+4 ; SDALVR("SDTYPE") .03 TYPE valid values:
+5 ; I:IHS
+6 ; C:CONTRACT
+7 ; T:TRIBAL
+8 ; O:OTHER
+9 ; 6:638 PROGRAM
+10 ; V:VA
+11 ; SDPAT .05 Patient pointer to PATIENT file 2
+12 ; SDLOC .06 LOC. OF ENCOUNTER pointer to LOCATION file
+13 ; SDCAT .07 Service Category
+14 ; SDCLN .08 DSS ID (Clinic Stop)
+15 ; SDPVL .12 Parent Visit Link
+16 ; .13 Date Last Modified in fm format
+17 ; SDCODT .18 Check out Date&Time
+18 ; SDVELG .21 Eligibility pointer to ELIGIBILITY CODE file 8
+19 ; SDHL .22 Hospital Location pointer to file 44
+20 ; SDUSR .23 Created by user pointer to NEW PERSON
+21 ; SDOPT .24 Option used to Create pointer to OPTION file
+22 ; SDPROT .25 Protocol pointer to PROTOCOL file
+23 ; SDOLOC 2101 outside location
+24 ;
+25 NEW AUPNDOB,AUPNDOD,AUPNSEX
+26 NEW SDDOB,SDDOD,SDFDA,SDIEN,SDMSG,SDSEX,X,Y,%DT
+27 SET Y=SDPAT
DO ^AUPNPAT
KILL Y
+28 SET SDSEX=AUPNSEX
SET SDDOB=AUPNDOB
SET SDDOD=AUPNDOD
+29 SET X=$GET(SDDATE)
SET %DT="TRXN"
DO ^%DT
SET X=Y
IF X=-1
SET SDAFLG=2
SET SDAFLG("ERR")=".01^"_SDDATE_"^DATE INVALID FOR PATIENT,CANNOT CREATE VISIT .01 VALUE"
QUIT
+30 DO VSIT01^AUPNVSIT
+31 IF '$DATA(X)
SET SDAFLG=2
SET SDAFLG("ERR")=".01^"_SDDATE_"^DATE INVALID FOR PATIENT,CANNOT CREATE VISIT .01 VALUE"
QUIT
+32 SET SDFDA="SDFDA(9000010,""+1,"")"
+33 SET @SDFDA@(.01)=SDDATE
+34 SET @SDFDA@(.02)=$$NOW^XLFDT
+35 SET @SDFDA@(.03)=$GET(SDTYPE)
+36 SET @SDFDA@(.05)=$GET(SDPAT)
+37 SET @SDFDA@(.06)=$GET(SDLOC)
+38 SET @SDFDA@(.07)=$GET(SDCAT)
+39 SET @SDFDA@(.08)=$GET(SDCLN)
+40 SET @SDFDA@(.12)=$GET(SDPVL)
+41 SET @SDFDA@(.13)=DT
+42 SET @SDFDA@(.18)=$GET(SDCODT)
+43 SET @SDFDA@(.21)=$GET(SDVELG)
+44 SET @SDFDA@(.22)=$GET(SDHL)
+45 SET @SDFDA@(.23)=$GET(SDUSR)
+46 SET @SDFDA@(.24)=$GET(SDOPT)
+47 SET @SDFDA@(.25)=$GET(SDPROT)
+48 SET @SDFDA@(2101)=$SELECT($GET(SDOLOC)]"":SDOLOC,1:"")
+49 SET VID=$$GETVID^VSITVID
SET @SDFDA@(15001)=VID
+50 DO UPDATE^DIE("","SDFDA","SDIEN","SDMSG")
+51 ;
+52 IF $DATA(SDMSG)
SET SDAFLG=2
SET SDAFLG("ERR")=".01^"_SDALVR("CDT")_"^VISIT CREATION FAILED"
QUIT
+53 SET SDVSIT=+SDIEN(1)
+54 IF $TEXT(GETVID^VSITVID)]""
IF $PIECE($GET(^DIC(150.9,1,4)),U,2)]""
SET VID=$$GETVID^VSITVID
SET DIE=9000010
SET DA=SDVSIT
SET DR="15001///"_VID
DO ^DIE
KILL VID,DIE,DR,DA
+55 SET SDVSIT("NEW")=1
+56 QUIT
+57 ;
+58 ;--------------------------------------------------------------
+59 ;
INIT ; INITIALIZATION/EDIT INPUT VARIABLES
+1 DO INIT^SDECALV1
+2 QUIT
+3 ;
EOJ ; CLEAN UP
+1 LOCK -^TMP("SDECALV",SDPAT)
+2 ; The line below must 'hard set' the clinic code because
+3 ; ^DIE would have to be called recursively. An exception to the
+4 ; standard has been granted by DSM/OIRM.
+5 ; ***** BAD, VERY BAD, FORGIVE US PLEASE *****
IF SDVSIT
IF $DATA(SDCLN)
IF $PIECE(^AUPNVSIT(SDVSIT,0),U,8)=""
SET $PIECE(^AUPNVSIT(SDVSIT,0),U,8)=SDCLN
+6 ;I SDVSIT,$P($G(^AUPNVSIT(SDVSIT,11)),U,4)="" S $P(^AUPNVSIT(SDVSIT,11),U,4)=$$UID^AUPNVSIT(SDVSIT) ;stuff UID if blank
+7 KILL X,Y
+8 KILL DIRUT,DTOUT,DUOUT
+9 KILL SDADD,SDADF
+10 KILL SDAC,SDAI,SDAL,SDALV,SDAO,SDAVD,SDAVDC,SDAX,SDA11
+11 IF $DATA(SDALVR)\10
SET SDALVR("SDPAT")=SDPAT
SET SDALVR("SDVSIT")=SDVSIT
if $DATA(SDVSIT("NEW"))
SET SDALVR("SDVSIT","NEW")=SDVSIT("NEW")
if $DATA(SDAFLG)
SET SDALVR("SDAFLG")=SDAFLG
DO EN1^SDECEKL
+12 QUIT
