Routine: VPRHST

VPRHST ;SLC/MKB -- Test HS utilities ;09/18/18 4:36pm

 ;;1.0;VIRTUAL PATIENT RECORD;**8,25,27**;Sep 01, 2011;Build 10

 ;;Per VA Directive 6402, this routine should not be modified.

 ; External References          DBIA#

 ; -------------------          -----

 ; %ZIS                         10086

 ; DIC                           2051

 ; DID                           2052

 ; DIR                          10026

EN ; -- test VPRHS, write results to screen

 N DFN,TYPE,VPRZTEST S VPRZTEST=1

 F  S DFN=$$PATIENT Q:DFN<1  D

 . F  S TYPE=$$SOURCE Q:"^"[TYPE  D RUN W !! ;$$CONTNR

RUN ; -- get search parameters, run and display

 N START,STOP,MAX,ID,FMT,IN,OUT,TOTAL,I,X,RTN,DONE,QUIT

 S START=$$START Q:START="^"

 I START S STOP=$$STOP(START) Q:STOP="^"

 S MAX=$$TOTAL Q:MAX="^"

 ; ID=$$ITEM Q:ID="^"

 S FMT=1 ;$$FORMAT Q:FMT="^"

 S:$G(START) IN("start")=START

 S:$G(STOP) IN("stop")=STOP

 S:$G(MAX) IN("max")=MAX

 D GET^VPRHS(DFN,TYPE,,.IN,1,.OUT)

 D ^%ZIS

 S TOTAL=$O(@OUT@("A"),-1),RTN=$S(FMT:"XML",1:"JSON")_"^VPRHST1(X)"

 W !!,"#Results: "_TOTAL Q:TOTAL<1

 S I=0 F  S I=$O(@OUT@(I)) Q:I<1  D  Q:$G(QUIT)

 . I '$G(DONE) D READ Q:$G(QUIT)

 . W !,"Result #"_I,! S X=@OUT@(I) D @RTN

 K @OUT

 D HOME^%ZIS

READ ; -- continue?

 N X K DONE,QUIT

 W !!,"Press <return> to continue or ^ to exit results ..." R X:DTIME

 S:X["^" QUIT=1

PATIENT() ; -- select patient

 N X,Y,DIC

 S DIC=2,DIC(0)="AEQM" D ^DIC

Q Y

SOURCE() ; -- select SDA source

 N X,Y,DIC,DA,FN

 S DIC=560.1,DIC(0)="AEQMZ",DIC("A")="Select CONTAINER: "

 S DIC("S")="I $O(^(1,0))" D ^DIC I Y<1 Q "^"

 S DA=+Y,Y=$P(Y(0),U,2)

 I $P($G(^VPRC(560.1,DA,1,0)),U,4)>1 D

 . S FN=$$FILE(DA) S:FN>1 Y=Y_";"_FN

 . I FN="^" S Y="^"

Q Y

FILE(CONT) ; -- select optional source file for CONTainer

 N I,X,Y,Z,DIR,GBL S CONT=$G(CONT)

 S CONT=$S(CONT:+CONT,$L(CONT):+$O(^VPRC(560.1,"C",CONT,0)),1:0)

 S DIR("A")="Select SOURCE FILE: ",DIR(0)="SAO^",Y=""

 F I=1:1 S X=$G(^VPRC(560.1,CONT,1,I,0)) Q:X=""  D

 . S Z=$$GET1^DID(+X,,,"NAME")

 . I Z="" S GBL="^DD(+X,0,""NM"")",Z=$O(@GBL@("")) ;subfile

 . S DIR(0)=DIR(0)_+X_":"_Z_";"

 S DIR("?")="Select a VistA source file for this container, or press return for all."

 K X D:CONT ^DIR

Q Y

CONTNR() ; -- select SDA container

 N X,Y,DIC

 S DIC="^VPRC(560.1,",DIC(0)="AEQMZ",DIC("A")="Select CONTAINER: "

 S DIC("S")="I $O(^(1,0))" D ^DIC I Y<1 Q "^"

 S Y=$P($G(Y(0)),U,2)

Q Y

START() ; -- select a start date

 N X,Y,DIR,DUOUT,DTOUT

 S DIR(0)="DAO^::AEPT",DIR("A")="Select START DATE: "

 S DIR("?")="Enter an optional date[.time] to begin searching for data"

 D ^DIR S:$D(DTOUT) Y="^"

Q Y

STOP(START) ; -- select a stop date

 N X,Y,DIR,DUOUT,DTOUT

 S DIR(0)="DA^"_START_"::AEPT",DIR("A")="Select STOP DATE: "

 S DIR("?")="Enter a date[.time] after the START to end searching for data"

 D ^DIR S:$D(DTOUT) Y="^"

Q Y

TOTAL() ; -- select the max# to return

 N X,Y,DIR,DUOUT,DTOUT

 S DIR(0)="NAO^1:99999",DIR("A")="Select TOTAL #items: "

 S DIR("?")="Enter an optional maximum number of items to return per VistA source for this container, up to 99999"

 D ^DIR S:$D(DTOUT) Y="^"

Q Y

ITEM() ; -- select an item ID to return

 N X,Y,DIR,DUOUT,DTOUT

 S DIR(0)="FAO^1:20",DIR("A")="ID: "

 S DIR("?")="Enter the id of a record to return, if known; press return to view all records in this container."

 D ^DIR S:$D(DTOUT) Y="^"

Q Y

FORMAT() ; -- select output format

 N X,Y,DIR,DUOUT,DTOUT

 S DIR(0)="SAO^0:JSON;1:XML;",DIR("A")="Select FORMAT: ",DIR("B")="XML"

 S DIR("?")="Choose your desired output format, XML or JSON"

 D ^DIR S:$D(DUOUT) Y="^"

Q Y

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPRHST   3693     printed  Feb 19, 2025@00:11:43                                                                                                                                                                                                      Page 2

VPRHST    ;SLC/MKB -- Test HS utilities ;09/18/18 4:36pm

 +1       ;;1.0;VIRTUAL PATIENT RECORD;**8,25,27**;Sep 01, 2011;Build 10

 +2       ;;Per VA Directive 6402, this routine should not be modified.

 +3       ;

 +4       ; External References          DBIA#

 +5       ; -------------------          -----

 +6       ; %ZIS                         10086

 +7       ; DIC                           2051

 +8       ; DID                           2052

 +9       ; DIR                          10026

 +10      ;

EN        ; -- test VPRHS, write results to screen

 +1        NEW DFN,TYPE,VPRZTEST

           SET VPRZTEST=1

 +2        FOR

               SET DFN=$$PATIENT

               if DFN<1

                   QUIT

               Begin DoDot:1

 +3       ;$$CONTNR

FOR

                       SET TYPE=$$SOURCE

                       if "^"[TYPE

                           QUIT

                       DO RUN

                       WRITE !!

               End DoDot:1

 +4        QUIT

 +5       ;

RUN       ; -- get search parameters, run and display

 +1        NEW START,STOP,MAX,ID,FMT,IN,OUT,TOTAL,I,X,RTN,DONE,QUIT

 +2        SET START=$$START

           if START="^"

               QUIT

 +3        IF START

               SET STOP=$$STOP(START)

               if STOP="^"

                   QUIT

 +4        SET MAX=$$TOTAL

           if MAX="^"

               QUIT

 +5       ; ID=$$ITEM Q:ID="^"

 +6       ;$$FORMAT Q:FMT="^"

           SET FMT=1

 +7       ;

 +8        if $GET(START)

               SET IN("start")=START

 +9        if $GET(STOP)

               SET IN("stop")=STOP

 +10       if $GET(MAX)

               SET IN("max")=MAX

 +11       DO GET^VPRHS(DFN,TYPE,,.IN,1,.OUT)

 +12       DO ^%ZIS

 +13      ;

 +14       SET TOTAL=$ORDER(@OUT@("A"),-1)

           SET RTN=$SELECT(FMT:"XML",1:"JSON")_"^VPRHST1(X)"

 +15       WRITE !!,"#Results: "_TOTAL

           if TOTAL<1

               QUIT

 +16       SET I=0

FOR

               SET I=$ORDER(@OUT@(I))

               if I<1

                   QUIT

               Begin DoDot:1

 +17               IF '$GET(DONE)

                       DO READ

                       if $GET(QUIT)

                           QUIT

 +18               WRITE !,"Result #"_I,!

                   SET X=@OUT@(I)

                   DO @RTN

               End DoDot:1

               if $GET(QUIT)

                   QUIT

 +19       KILL @OUT

 +20       DO HOME^%ZIS

 +21       QUIT

 +22      ;

READ      ; -- continue?

 +1        NEW X

           KILL DONE,QUIT

 +2        WRITE !!,"Press <return> to continue or ^ to exit results ..."

           READ X:DTIME

 +3        if X["^"

               SET QUIT=1

 +4        QUIT

 +5       ;

PATIENT() ; -- select patient

 +1        NEW X,Y,DIC

 +2        SET DIC=2

           SET DIC(0)="AEQM"

           DO ^DIC

 +3        QUIT Y

 +4       ;

SOURCE()  ; -- select SDA source

 +1        NEW X,Y,DIC,DA,FN

 +2        SET DIC=560.1

           SET DIC(0)="AEQMZ"

           SET DIC("A")="Select CONTAINER: "

 +3        SET DIC("S")="I $O(^(1,0))"

           DO ^DIC

           IF Y<1

               QUIT "^"

 +4        SET DA=+Y

           SET Y=$PIECE(Y(0),U,2)

 +5        IF $PIECE($GET(^VPRC(560.1,DA,1,0)),U,4)>1

               Begin DoDot:1

 +6                SET FN=$$FILE(DA)

                   if FN>1

                       SET Y=Y_";"_FN

 +7                IF FN="^"

                       SET Y="^"

               End DoDot:1

 +8        QUIT Y

 +9       ;

FILE(CONT) ; -- select optional source file for CONTainer

 +1        NEW I,X,Y,Z,DIR,GBL

           SET CONT=$GET(CONT)

 +2        SET CONT=$SELECT(CONT:+CONT,$LENGTH(CONT):+$ORDER(^VPRC(560.1,"C",CONT,0)),1:0)

 +3        SET DIR("A")="Select SOURCE FILE: "

           SET DIR(0)="SAO^"

           SET Y=""

 +4        FOR I=1:1

               SET X=$GET(^VPRC(560.1,CONT,1,I,0))

               if X=""

                   QUIT

               Begin DoDot:1

 +5                SET Z=$$GET1^DID(+X,,,"NAME")

 +6       ;subfile

                   IF Z=""

                       SET GBL="^DD(+X,0,""NM"")"

                       SET Z=$ORDER(@GBL@(""))

 +7                SET DIR(0)=DIR(0)_+X_":"_Z_";"

               End DoDot:1

 +8        SET DIR("?")="Select a VistA source file for this container, or press return for all."

 +9        KILL X

           if CONT

               DO ^DIR

 +10       QUIT Y

 +11      ;

CONTNR()  ; -- select SDA container

 +1        NEW X,Y,DIC

 +2        SET DIC="^VPRC(560.1,"

           SET DIC(0)="AEQMZ"

           SET DIC("A")="Select CONTAINER: "

 +3        SET DIC("S")="I $O(^(1,0))"

           DO ^DIC

           IF Y<1

               QUIT "^"

 +4        SET Y=$PIECE($GET(Y(0)),U,2)

 +5        QUIT Y

 +6       ;

START()   ; -- select a start date

 +1        NEW X,Y,DIR,DUOUT,DTOUT

 +2        SET DIR(0)="DAO^::AEPT"

           SET DIR("A")="Select START DATE: "

 +3        SET DIR("?")="Enter an optional date[.time] to begin searching for data"

 +4        DO ^DIR

           if $DATA(DTOUT)

               SET Y="^"

 +5        QUIT Y

 +6       ;

STOP(START) ; -- select a stop date

 +1        NEW X,Y,DIR,DUOUT,DTOUT

 +2        SET DIR(0)="DA^"_START_"::AEPT"

           SET DIR("A")="Select STOP DATE: "

 +3        SET DIR("?")="Enter a date[.time] after the START to end searching for data"

 +4        DO ^DIR

           if $DATA(DTOUT)

               SET Y="^"

 +5        QUIT Y

 +6       ;

TOTAL()   ; -- select the max# to return

 +1        NEW X,Y,DIR,DUOUT,DTOUT

 +2        SET DIR(0)="NAO^1:99999"

           SET DIR("A")="Select TOTAL #items: "

 +3        SET DIR("?")="Enter an optional maximum number of items to return per VistA source for this container, up to 99999"

 +4        DO ^DIR

           if $DATA(DTOUT)

               SET Y="^"

 +5        QUIT Y

 +6       ;

ITEM()    ; -- select an item ID to return

 +1        NEW X,Y,DIR,DUOUT,DTOUT

 +2        SET DIR(0)="FAO^1:20"

           SET DIR("A")="ID: "

 +3        SET DIR("?")="Enter the id of a record to return, if known; press return to view all records in this container."

 +4        DO ^DIR

           if $DATA(DTOUT)

               SET Y="^"

 +5        QUIT Y

 +6       ;

FORMAT()  ; -- select output format

 +1        NEW X,Y,DIR,DUOUT,DTOUT

 +2        SET DIR(0)="SAO^0:JSON;1:XML;"

           SET DIR("A")="Select FORMAT: "

           SET DIR("B")="XML"

 +3        SET DIR("?")="Choose your desired output format, XML or JSON"

 +4        DO ^DIR

           if $DATA(DUOUT)

               SET Y="^"

 +5        QUIT Y

VPRHST.m