- WIIADT1 ;VISN20/WDE/WHN/WII RPC TO GET DATA FROM FILE 987.7 ; [6/26/08 07:21am]
- ;;1.0;Wounded Injured and Ill Warriors;**1**;06/26/2008;Build 28;
- ;THIS ROUTINE IS CALLED FROM THE REMOTE PROCEDURE WII ADT. It creates a list of entries from WII ADT ALL SITES (#987.7)
- ;No outside API'S or DBIA's are used
- EN(RESULTS,WIISTDT) ;Entry Point
- K ^TMP($J)
- S RESULTS=$NA(^TMP($J))
- D NOW^%DTC S DT=X K X,Y,%
- I $G(WIISTDT)="" D LOOP1
- I $G(WIISTDT)'="" D LOOP2 ;this is to recreate the list
- I $D(^TMP($J))=0 S ^TMP($J,1,0)="No data has been transmitted with the date you selected"
- D CLEAN
- Q
- ;---------------------------------------------------------------------------------------------------------------
- LOOP1 ;tag is used to collect records that have a status of 1
- S (WIICNT,WIIENT)=0 F S WIIENT=$O(^WII(987.7,"C",1,WIIENT)) Q:(WIIENT="")!('+WIIENT) D
- . D BUILD
- . Q
- I $D(^TMP($J))=0 S RESULTS="NO DATA TO TRANSMIT"
- D CLEAN
- Q
- LOOP2 ;
- S X=WIISTDT D ^%DT S WIISTDT=Y K Y
- S (WIIENT,WIICNT)=0 F S WIIENT=$O(^WII(987.7,"D",WIISTDT,WIIENT)) Q:(WIIENT="")!('+WIIENT) D
- . D BUILD
- . Q
- D CLEAN
- Q
- BUILD ;
- S WIIDATA=$G(^WII(987.7,WIIENT,0)) Q:WIIDATA=""
- S WIIP1=$P($G(WIIDATA),U,2),WIIP1=WIIP1_" ",WIIP1=$E(WIIP1,1,6) ;FACILITY SIZE 6
- S WIIP2=" " ;PLACE HOLDER FOR FUTURE. WILL BE ADD DELETE UPDATE CHARACTER SIZE 1
- S WIIP3A=$P($G(WIIDATA),U,5),WIIP3A=$P($G(WIIP3A),"@",1),WIIP3A=WIIP3A_" ",WIIP3A=$E(WIIP3A,1,10) ;admit date no time
- S WIIP3B=$P($G(WIIDATA),U,5),WIIP3B=$P($G(WIIP3B),"@",2)
- S WIIP3B=$$STRIP^XLFSTR(WIIP3B,":") ;now strip off the colon makes it
- S WIIP3B=WIIP3B_" ",WIIP3B=$E(WIIP3B,1,4) ;admit TIME no DATE
- S WIIP4A=$P($G(WIIDATA),U,3),WIIP4A=WIIP4A_" ",WIIP4A=$E(WIIP4A,1,35) ;LAST NAME
- S WIIP5A=$P($G(WIIDATA),U,4),WIIP5A=WIIP5A_" ",WIIP5A=$E(WIIP5A,1,9) ;SSN
- S WIIP5B=$P($G(WIIDATA),U,4),WIIP5B=WIIP5B_" ",WIIP5B=$E(WIIP5B,10) ;Pseudo CHARACTER
- S WIIP6A=$P($G(WIIDATA),U,6),WIIP6A=$P($G(WIIP6A),"@",1),WIIP6A=WIIP6A_" ",WIIP6A=$E(WIIP6A,1,10) ;discharge date no time
- S WIIP6B=$P($G(WIIDATA),U,6),WIIP6B=$P($G(WIIP6B),"@",2)
- S WIIP6B=$$STRIP^XLFSTR(WIIP6B,":") ;now strip off the colon
- S WIIP6B=WIIP6B_" ",WIIP6B=$E(WIIP6B,1,4) ;discharge TIME no DATE
- ;NOW GET THE FULL NAME COMPONETS
- S WIIDATA=$G(^WII(987.7,WIIENT,1))
- S WIIP4B=$P($G(WIIDATA),U,7),WIIP4B=WIIP4B_" ",WIIP4B=$E(WIIP4B,1,35) ;FIRST NAME
- S WIIP4C=$P($G(WIIDATA),U,8),WIIP4C=WIIP4C_" ",WIIP4C=$E(WIIP4C,1,2) ;MIDDLE NAME
- S WIISTRG=WIIP1_WIIP2_WIIP3A_WIIP3B_WIIP4A_WIIP4B_WIIP4C_WIIP5A_WIIP5B_WIIP6A_WIIP6B
- S WIICNT=WIICNT+1
- S ^TMP($J,WIICNT,0)=WIISTRG
- S WIIDFAS=$P($G(^WII(987.7,WIIENT,0)),U,9) ;if there is a date then the user regenerated the list no need to go on.
- I WIIDFAS'="" Q
- S DIE="^WII(987.7,",DA=WIIENT,DR="8///"_DT_";9///2"
- D ^DIE
- Q
- CLEAN ;
- S RESULTS=$NA(^TMP($J))
- K XMDUZ,XMY,WIIREV,WIIDFAS
- K WIIENT,WIICNT,WIIDATA,WIIP2,WIIP3,WIIP4,WIIP5,WIIP6,WIIP7,WIIP8,WIIP9,WIIP10,WIISTRG
- K DA,DIC,DIE,DR
- K WII1,WII3,WII4,WIIDELIM,WIITMP
- K WIIP8,WIIP9,WIIP10,WIIP11
- K WIIP3A,WIIP3B,WIIP4A,WIIP4B,WIIP4C,WIIP1,WIIP5A,WIIP5B,WIIP5C,WIIP6A,WIIP6B
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HWIIADT1 3302 printed Feb 19, 2025@00:12:58 Page 2
- WIIADT1 ;VISN20/WDE/WHN/WII RPC TO GET DATA FROM FILE 987.7 ; [6/26/08 07:21am]
- +1 ;;1.0;Wounded Injured and Ill Warriors;**1**;06/26/2008;Build 28;
- +2 ;THIS ROUTINE IS CALLED FROM THE REMOTE PROCEDURE WII ADT. It creates a list of entries from WII ADT ALL SITES (#987.7)
- +3 ;No outside API'S or DBIA's are used
- EN(RESULTS,WIISTDT) ;Entry Point
- +1 KILL ^TMP($JOB)
- +2 SET RESULTS=$NAME(^TMP($JOB))
- +3 DO NOW^%DTC
- SET DT=X
- KILL X,Y,%
- +4 IF $GET(WIISTDT)=""
- DO LOOP1
- +5 ;this is to recreate the list
- IF $GET(WIISTDT)'=""
- DO LOOP2
- +6 IF $DATA(^TMP($JOB))=0
- SET ^TMP($JOB,1,0)="No data has been transmitted with the date you selected"
- +7 DO CLEAN
- +8 QUIT
- +9 ;---------------------------------------------------------------------------------------------------------------
- LOOP1 ;tag is used to collect records that have a status of 1
- +1 SET (WIICNT,WIIENT)=0
- FOR
- SET WIIENT=$ORDER(^WII(987.7,"C",1,WIIENT))
- if (WIIENT="")!('+WIIENT)
- QUIT
- Begin DoDot:1
- +2 DO BUILD
- +3 QUIT
- End DoDot:1
- +4 IF $DATA(^TMP($JOB))=0
- SET RESULTS="NO DATA TO TRANSMIT"
- +5 DO CLEAN
- +6 QUIT
- LOOP2 ;
- +1 SET X=WIISTDT
- DO ^%DT
- SET WIISTDT=Y
- KILL Y
- +2 SET (WIIENT,WIICNT)=0
- FOR
- SET WIIENT=$ORDER(^WII(987.7,"D",WIISTDT,WIIENT))
- if (WIIENT="")!('+WIIENT)
- QUIT
- Begin DoDot:1
- +3 DO BUILD
- +4 QUIT
- End DoDot:1
- +5 DO CLEAN
- +6 QUIT
- BUILD ;
- +1 SET WIIDATA=$GET(^WII(987.7,WIIENT,0))
- if WIIDATA=""
- QUIT
- +2 ;FACILITY SIZE 6
- SET WIIP1=$PIECE($GET(WIIDATA),U,2)
- SET WIIP1=WIIP1_" "
- SET WIIP1=$EXTRACT(WIIP1,1,6)
- +3 ;PLACE HOLDER FOR FUTURE. WILL BE ADD DELETE UPDATE CHARACTER SIZE 1
- SET WIIP2=" "
- +4 ;admit date no time
- SET WIIP3A=$PIECE($GET(WIIDATA),U,5)
- SET WIIP3A=$PIECE($GET(WIIP3A),"@",1)
- SET WIIP3A=WIIP3A_" "
- SET WIIP3A=$EXTRACT(WIIP3A,1,10)
- +5 SET WIIP3B=$PIECE($GET(WIIDATA),U,5)
- SET WIIP3B=$PIECE($GET(WIIP3B),"@",2)
- +6 ;now strip off the colon makes it
- SET WIIP3B=$$STRIP^XLFSTR(WIIP3B,":")
- +7 ;admit TIME no DATE
- SET WIIP3B=WIIP3B_" "
- SET WIIP3B=$EXTRACT(WIIP3B,1,4)
- +8 ;LAST NAME
- SET WIIP4A=$PIECE($GET(WIIDATA),U,3)
- SET WIIP4A=WIIP4A_" "
- SET WIIP4A=$EXTRACT(WIIP4A,1,35)
- +9 ;SSN
- SET WIIP5A=$PIECE($GET(WIIDATA),U,4)
- SET WIIP5A=WIIP5A_" "
- SET WIIP5A=$EXTRACT(WIIP5A,1,9)
- +10 ;Pseudo CHARACTER
- SET WIIP5B=$PIECE($GET(WIIDATA),U,4)
- SET WIIP5B=WIIP5B_" "
- SET WIIP5B=$EXTRACT(WIIP5B,10)
- +11 ;discharge date no time
- SET WIIP6A=$PIECE($GET(WIIDATA),U,6)
- SET WIIP6A=$PIECE($GET(WIIP6A),"@",1)
- SET WIIP6A=WIIP6A_" "
- SET WIIP6A=$EXTRACT(WIIP6A,1,10)
- +12 SET WIIP6B=$PIECE($GET(WIIDATA),U,6)
- SET WIIP6B=$PIECE($GET(WIIP6B),"@",2)
- +13 ;now strip off the colon
- SET WIIP6B=$$STRIP^XLFSTR(WIIP6B,":")
- +14 ;discharge TIME no DATE
- SET WIIP6B=WIIP6B_" "
- SET WIIP6B=$EXTRACT(WIIP6B,1,4)
- +15 ;NOW GET THE FULL NAME COMPONETS
- +16 SET WIIDATA=$GET(^WII(987.7,WIIENT,1))
- +17 ;FIRST NAME
- SET WIIP4B=$PIECE($GET(WIIDATA),U,7)
- SET WIIP4B=WIIP4B_" "
- SET WIIP4B=$EXTRACT(WIIP4B,1,35)
- +18 ;MIDDLE NAME
- SET WIIP4C=$PIECE($GET(WIIDATA),U,8)
- SET WIIP4C=WIIP4C_" "
- SET WIIP4C=$EXTRACT(WIIP4C,1,2)
- +19 SET WIISTRG=WIIP1_WIIP2_WIIP3A_WIIP3B_WIIP4A_WIIP4B_WIIP4C_WIIP5A_WIIP5B_WIIP6A_WIIP6B
- +20 SET WIICNT=WIICNT+1
- +21 SET ^TMP($JOB,WIICNT,0)=WIISTRG
- +22 ;if there is a date then the user regenerated the list no need to go on.
- SET WIIDFAS=$PIECE($GET(^WII(987.7,WIIENT,0)),U,9)
- +23 IF WIIDFAS'=""
- QUIT
- +24 SET DIE="^WII(987.7,"
- SET DA=WIIENT
- SET DR="8///"_DT_";9///2"
- +25 DO ^DIE
- +26 QUIT
- CLEAN ;
- +1 SET RESULTS=$NAME(^TMP($JOB))
- +2 KILL XMDUZ,XMY,WIIREV,WIIDFAS
- +3 KILL WIIENT,WIICNT,WIIDATA,WIIP2,WIIP3,WIIP4,WIIP5,WIIP6,WIIP7,WIIP8,WIIP9,WIIP10,WIISTRG
- +4 KILL DA,DIC,DIE,DR
- +5 KILL WII1,WII3,WII4,WIIDELIM,WIITMP
- +6 KILL WIIP8,WIIP9,WIIP10,WIIP11
- +7 KILL WIIP3A,WIIP3B,WIIP4A,WIIP4B,WIIP4C,WIIP1,WIIP5A,WIIP5B,WIIP5C,WIIP6A,WIIP6B
- +8 QUIT
